From 075c0379aead4b031a71fbd65e1d0b393d2dfd46 Mon Sep 17 00:00:00 2001 From: "russ.treadon" Date: Mon, 11 May 2020 19:31:38 +0000 Subject: [PATCH 1/5] Vlab issue #65376: DA changes for GFSv16. Fixes #65376. Change-Id: Id7ea8df4b8f5b2b7961456c5c961c1ad712385a6 --- CMakeLists.txt | 22 +- cmake/Modules/FindHDF5.cmake | 1 - cmake/Modules/FindIP.cmake | 83 + cmake/Modules/platforms/Cheyenne.cmake | 2 +- cmake/Modules/platforms/Discover.cmake | 2 +- cmake/Modules/platforms/Gaea.cmake | 2 +- cmake/Modules/platforms/Generic.cmake | 2 +- cmake/Modules/platforms/Hera.cmake | 6 +- cmake/Modules/platforms/Jet.cmake | 2 +- cmake/Modules/platforms/Orion.cmake | 42 + cmake/Modules/platforms/S4.cmake | 2 +- cmake/Modules/platforms/WCOSS-D.cmake | 6 +- cmake/Modules/setHOST.cmake | 6 + cmake/Modules/setIntelFlags.cmake | 4 +- cmake/Modules/setPlatformVariables.cmake | 1 + fix | 2 +- jobs/JGDAS_ENKF_POST | 3 +- jobs/JGDAS_ENKF_RECENTER | 5 +- jobs/JGDAS_ENKF_SURFACE | 143 + jobs/JGLOBAL_ANALCALC | 172 + jobs/JGLOBAL_ANALDIAG | 172 + jobs/JGLOBAL_ANALYSIS | 15 +- jobs/JGLOBAL_ENKF_ANALDIAG | 200 + jobs/JGLOBAL_ENKF_INNOVATE_OBS | 7 +- jobs/JGLOBAL_ENKF_SELECT_OBS | 9 +- jobs/JGLOBAL_ENKF_UPDATE | 5 +- modulefiles/modulefile.ProdGSI.hera | 14 +- modulefiles/modulefile.ProdGSI.orion | 46 + modulefiles/modulefile.ProdGSI.wcoss_c | 12 +- modulefiles/modulefile.ProdGSI.wcoss_d | 17 +- regression/global_4denvar_T126.sh | 3 + regression/global_4dvar_T62.sh | 2 + regression/global_T62.sh | 2 + regression/global_T62_ozonly.sh | 2 + regression/global_enkf_T62.sh | 2 + regression/global_fv3_4denvar_C192.sh | 425 ++ regression/global_fv3_4denvar_T126.sh | 8 + regression/global_hybrid_T126.sh | 2 + regression/global_lanczos_T62.sh | 2 + regression/global_nemsio_T62.sh | 2 + regression/multi_regression.sh | 2 + regression/regression_namelists.sh | 219 +- regression/regression_namelists_db.sh | 200 + regression/regression_nl_update.sh | 7 +- regression/regression_param.sh | 32 +- regression/regression_test.sh | 40 +- regression/regression_var.sh | 3 + scripts/exglobal_analcalc_fv3gfs.sh.ecf | 245 ++ scripts/exglobal_analdiag_fv3gfs.sh.ecf | 298 ++ scripts/exglobal_analysis_fv3gfs.sh.ecf | 458 +- scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf | 20 +- scripts/exglobal_enkf_post_fv3gfs.sh.ecf | 17 +- scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf | 415 +- scripts/exglobal_enkf_surface_fv3gfs.sh.ecf | 225 + scripts/exglobal_enkf_update_fv3gfs.sh.ecf | 153 +- scripts/exglobal_innovate_obs_fv3gfs.sh.ecf | 4 +- src/enkf/CMakeLists.txt | 8 +- src/enkf/README.shmem | 14 - src/enkf/controlvec.f90 | 57 +- src/enkf/enkf.f90 | 5 +- src/enkf/enkf_main.f90 | 3 +- src/enkf/enkf_obs_sensitivity.f90 | 4 +- src/enkf/enkf_obsmod.f90 | 36 +- src/enkf/gridinfo_gfs.f90 | 43 +- src/enkf/gridio_gfs.f90 | 3912 ++++++++++++++--- src/enkf/gridio_wrf.f90 | 17 +- src/enkf/inflation.f90 | 6 +- src/enkf/{letkf.F90 => letkf.f90} | 146 +- src/enkf/loadbal.f90 | 78 +- src/enkf/mpi_readobs.f90 | 229 +- src/enkf/{mpisetup.F90 => mpisetup.f90} | 4 - src/enkf/observer_gfs.f90 | 70 +- src/enkf/observer_reg.f90 | 65 +- src/enkf/params.f90 | 84 +- src/enkf/radbias.f90 | 4 +- src/enkf/read_locinfo.f90 | 4 +- src/enkf/readconvobs.f90 | 167 +- src/enkf/readozobs.f90 | 88 +- src/enkf/readsatobs.f90 | 128 +- src/enkf/smooth_gfs.f90 | 4 +- src/enkf/statevec.f90 | 26 +- src/fv3gfs_ncio/CMakeLists.txt | 10 + src/fv3gfs_ncio/module_fv3gfs_ncio.f90 | 1338 ++++++ src/fv3gfs_ncio/quantize_data_code.f90 | 17 + src/fv3gfs_ncio/read_attribute_code.f90 | 35 + .../read_scalar_attribute_code.f90 | 31 + src/fv3gfs_ncio/read_vardata_code_1d.f90 | 75 + src/fv3gfs_ncio/read_vardata_code_2d.f90 | 81 + src/fv3gfs_ncio/read_vardata_code_3d.f90 | 85 + src/fv3gfs_ncio/read_vardata_code_4d.f90 | 83 + src/fv3gfs_ncio/read_vardata_code_5d.f90 | 35 + src/fv3gfs_ncio/write_attribute_code.f90 | 37 + src/fv3gfs_ncio/write_vardata_code.f90 | 97 + src/gsi/CMakeLists.txt | 4 +- src/gsi/anisofilter_glb.f90 | 4 +- src/gsi/berror.f90 | 36 +- src/gsi/constants.f90 | 16 +- src/gsi/control_vectors.f90 | 14 + src/gsi/convinfo.f90 | 29 +- src/gsi/correlated_obsmod.F90 | 30 +- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 9 +- src/gsi/cplr_gfs_ensmod.f90 | 266 +- src/gsi/cplr_gfs_nstmod.f90 | 6 +- src/gsi/crtm_interface.f90 | 11 +- src/gsi/general_read_gfsatm.f90 | 754 +++- src/gsi/genstats_gps.f90 | 15 +- src/gsi/{gesinfo.f90 => gesinfo.F90} | 97 +- src/gsi/gfs_stratosphere.f90 | 97 +- src/gsi/gridmod.F90 | 9 + src/gsi/gsi_rfv3io_mod.f90 | 8 +- src/gsi/gsimod.F90 | 38 +- src/gsi/guess_grids.F90 | 11 + src/gsi/hybrid_ensemble_isotropic.F90 | 2 +- src/gsi/intps.f90 | 38 +- src/gsi/intq.f90 | 42 +- src/gsi/intt.f90 | 31 +- src/gsi/intw.f90 | 31 +- src/gsi/jfunc.f90 | 5 + src/gsi/kinds.F90 | 6 + src/gsi/m_psNode.F90 | 7 + src/gsi/m_qNode.F90 | 7 + src/gsi/m_tNode.F90 | 11 + src/gsi/m_wNode.F90 | 8 +- src/gsi/ncepgfs_io.f90 | 64 +- src/gsi/ncepnems_io.f90 | 29 +- src/gsi/netcdfgfs_io.f90 | 3112 +++++++++++++ src/gsi/obsmod.F90 | 6 +- src/gsi/pcgsoi.f90 | 4 +- src/gsi/phil.f90 | 2 +- src/gsi/phil0.f90 | 1592 +++++++ src/gsi/phil1.f90 | 2 +- src/gsi/phil2.f90 | 891 ++++ src/gsi/pietc.f90 | 95 + src/gsi/pmat.f90 | 1131 +++++ src/gsi/pmat4.f90 | 1854 ++++++++ src/gsi/pmat6.f90 | 92 + src/gsi/psort.f90 | 703 +++ src/gsi/pvqc.f90 | 620 +++ src/gsi/pvqc_tables.f90 | 40 + src/gsi/q_diag.f90 | 21 +- src/gsi/qcmod.f90 | 607 +-- src/gsi/radiance_mod.f90 | 4 +- src/gsi/radinfo.f90 | 18 +- src/gsi/read_abi.f90 | 57 +- src/gsi/read_aerosol.f90 | 1 - src/gsi/read_ahi.f90 | 171 +- src/gsi/read_atms.f90 | 1 - src/gsi/read_cris.f90 | 19 +- src/gsi/read_dbz_netcdf.f90 | 1 - src/gsi/read_files.f90 | 65 +- src/gsi/read_fl_hdob.f90 | 3 +- src/gsi/read_gps.f90 | 4 +- src/gsi/read_guess.F90 | 23 +- src/gsi/read_nsstbufr.f90 | 71 +- src/gsi/read_obs.F90 | 19 +- src/gsi/read_ozone.f90 | 31 +- src/gsi/read_prepbufr.f90 | 201 +- src/gsi/read_saphir.f90 | 2 +- src/gsi/read_satwnd.f90 | 86 +- src/gsi/read_seviri.f90 | 74 +- src/gsi/read_ssmis.f90 | 2 +- src/gsi/rtma_comp_fact10.f90 | 2 +- src/gsi/satthin.F90 | 24 +- src/gsi/setupbend.f90 | 120 +- src/gsi/setupdw.f90 | 13 +- src/gsi/setuplwcp.f90 | 13 +- src/gsi/setupoz.f90 | 33 +- src/gsi/setupps.f90 | 68 +- src/gsi/setuppw.f90 | 13 +- src/gsi/setupq.f90 | 78 +- src/gsi/setuprad.f90 | 74 +- src/gsi/setupref.f90 | 8 +- src/gsi/setuprw.f90 | 12 +- src/gsi/setupspd.f90 | 13 +- src/gsi/setupsst.f90 | 8 + src/gsi/setupswcp.f90 | 13 +- src/gsi/setupt.f90 | 87 +- src/gsi/setuptcp.f90 | 13 +- src/gsi/setupw.f90 | 89 +- src/gsi/sparsearr.f90 | 24 +- src/gsi/stpaod.f90 | 6 +- src/gsi/stpps.f90 | 54 +- src/gsi/stpq.f90 | 51 +- src/gsi/stpt.f90 | 51 +- src/gsi/stpw.f90 | 57 +- src/gsi/vqc_int.f90 | 60 + src/gsi/vqc_setup.f90 | 112 + src/gsi/vqc_stp.f90 | 67 + src/gsi/write_all.F90 | 4 +- src/gsi/write_incr.f90 | 562 +++ src/ncdiag/serial/CMakeLists.txt | 2 +- ush/build_all_cmake.sh | 7 +- ush/calcanl_gfs.py | 378 ++ ush/calcinc_gfs.py | 90 + ush/getgfsnctime | 34 + ush/getncdimlen | 17 + ush/gsi_utils.py | 123 + .../plots_py/plot_global_inc.py | 40 + .../calc_increment_ens_ncio.fd/CMakeLists.txt | 14 + .../calc_increment_interface.f90 | 75 + .../calc_increment_ens_ncio.fd/constants.f90 | 314 ++ .../fv3_interface.f90 | 708 +++ .../gfs_ncio_interface.f90 | 359 ++ .../src/calc_increment_ens_ncio.fd/kinds.f90 | 107 + .../src/calc_increment_ens_ncio.fd/main.f90 | 37 + .../namelist_def.f90 | 81 + .../src/calc_increment_ens_ncio.fd/pmain.f90 | 80 + .../src/calc_increment_ncio.fd/CMakeLists.txt | 11 + .../calc_increment_ncio.f90 | 389 ++ .../gfs/src/getsfcensmeanp.fd/CMakeLists.txt | 4 +- .../src/getsfcensmeanp.fd/getsfcensmeanp.f90 | 79 +- .../src/getsfcnstensupdp.fd/CMakeLists.txt | 2 - .../getsigensmeanp_smooth.fd/CMakeLists.txt | 4 +- .../getsigensmeanp_smooth_ncep.f90 | 516 ++- .../gfs/src/getsigensstatp.fd/CMakeLists.txt | 4 +- .../src/getsigensstatp.fd/getsigensstatp.f90 | 133 +- .../recenterncio_hybgain.fd/CMakeLists.txt | 10 + .../recenterncio_hybgain.f90 | 240 + .../gfs/src/recentersigp.fd/CMakeLists.txt | 4 +- .../gfs/src/recentersigp.fd/recentersigp.f90 | 233 +- .../Ozone_Monitor/image_gen/ush/mk_summary.sh | 17 +- .../fix/gdas_oznmon_satype.txt | 2 +- .../sorc/oznmon_horiz.fd/CMakeLists.txt | 2 +- .../sorc/oznmon_horiz.fd/read_diag.f90 | 90 +- .../sorc/oznmon_time.fd/CMakeLists.txt | 2 +- .../sorc/oznmon_time.fd/read_diag.f90 | 90 +- .../sorc/oznmon_time.fd/time.f90 | 64 +- .../sorc/oznmon_time.fd/valid.f90 | 12 +- util/Radiance_Monitor/CMakeLists.txt | 34 +- .../src/radmon_ig_horiz.fd/CMakeLists.txt | 2 +- .../image_gen/ush/run_plot_v16rt0.sh | 56 - .../driver/test_jgdas_verfrad_wcoss_d.sh | 19 +- .../fix/gdas_radmon_satype.txt | 3 +- .../fix/gdas_radmon_scaninfo.txt | 1 + .../sorc/verf_radang.fd/CMakeLists.txt | 2 +- .../sorc/verf_radbcoef.fd/CMakeLists.txt | 2 +- .../sorc/verf_radbcor.fd/CMakeLists.txt | 2 +- .../sorc/verf_radtime.fd/CMakeLists.txt | 2 +- .../{bad_obs.f90 => low_count.f90} | 61 +- .../sorc/verf_radtime.fd/time.f90 | 59 +- .../sorc/verf_radtime.fd/valid.f90 | 89 +- .../ush/radmon_err_rpt.sh | 61 +- .../ush/radmon_verf_time.sh | 241 +- util/netcdf_io/CMakeLists.txt | 23 + .../netcdf_io/calc_analysis.fd/CMakeLists.txt | 13 + util/netcdf_io/calc_analysis.fd/inc2anl.f90 | 278 ++ .../calc_analysis.fd/init_calc_analysis.f90 | 64 + util/netcdf_io/calc_analysis.fd/init_io.f90 | 217 + util/netcdf_io/calc_analysis.fd/main.f90 | 32 + .../calc_analysis.fd/vars_calc_analysis.f90 | 48 + util/netcdf_io/interp_inc.fd/CMakeLists.txt | 13 + util/netcdf_io/interp_inc.fd/driver.f90 | 510 +++ 252 files changed, 28601 insertions(+), 3613 deletions(-) create mode 100644 cmake/Modules/FindIP.cmake create mode 100644 cmake/Modules/platforms/Orion.cmake create mode 100755 jobs/JGDAS_ENKF_SURFACE create mode 100755 jobs/JGLOBAL_ANALCALC create mode 100755 jobs/JGLOBAL_ANALDIAG create mode 100755 jobs/JGLOBAL_ENKF_ANALDIAG create mode 100644 modulefiles/modulefile.ProdGSI.orion create mode 100755 regression/global_fv3_4denvar_C192.sh create mode 100755 scripts/exglobal_analcalc_fv3gfs.sh.ecf create mode 100755 scripts/exglobal_analdiag_fv3gfs.sh.ecf create mode 100755 scripts/exglobal_enkf_surface_fv3gfs.sh.ecf delete mode 100644 src/enkf/README.shmem rename src/enkf/{letkf.F90 => letkf.f90} (87%) rename src/enkf/{mpisetup.F90 => mpisetup.f90} (99%) create mode 100644 src/fv3gfs_ncio/CMakeLists.txt create mode 100644 src/fv3gfs_ncio/module_fv3gfs_ncio.f90 create mode 100644 src/fv3gfs_ncio/quantize_data_code.f90 create mode 100644 src/fv3gfs_ncio/read_attribute_code.f90 create mode 100644 src/fv3gfs_ncio/read_scalar_attribute_code.f90 create mode 100644 src/fv3gfs_ncio/read_vardata_code_1d.f90 create mode 100644 src/fv3gfs_ncio/read_vardata_code_2d.f90 create mode 100644 src/fv3gfs_ncio/read_vardata_code_3d.f90 create mode 100644 src/fv3gfs_ncio/read_vardata_code_4d.f90 create mode 100644 src/fv3gfs_ncio/read_vardata_code_5d.f90 create mode 100644 src/fv3gfs_ncio/write_attribute_code.f90 create mode 100644 src/fv3gfs_ncio/write_vardata_code.f90 rename src/gsi/{gesinfo.f90 => gesinfo.F90} (86%) create mode 100644 src/gsi/netcdfgfs_io.f90 create mode 100644 src/gsi/phil0.f90 create mode 100644 src/gsi/phil2.f90 create mode 100755 src/gsi/pietc.f90 create mode 100755 src/gsi/pmat.f90 create mode 100644 src/gsi/pmat4.f90 create mode 100644 src/gsi/pmat6.f90 create mode 100644 src/gsi/psort.f90 create mode 100755 src/gsi/pvqc.f90 create mode 100755 src/gsi/pvqc_tables.f90 create mode 100644 src/gsi/vqc_int.f90 create mode 100644 src/gsi/vqc_setup.f90 create mode 100644 src/gsi/vqc_stp.f90 create mode 100644 src/gsi/write_incr.f90 create mode 100755 ush/calcanl_gfs.py create mode 100755 ush/calcinc_gfs.py create mode 100755 ush/getgfsnctime create mode 100755 ush/getncdimlen create mode 100644 ush/gsi_utils.py create mode 100755 util/Analysis_Utilities/plots_py/plot_global_inc.py create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/CMakeLists.txt create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/calc_increment_interface.f90 create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/constants.f90 create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/fv3_interface.f90 create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/gfs_ncio_interface.f90 create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/kinds.f90 create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/main.f90 create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/namelist_def.f90 create mode 100644 util/EnKF/gfs/src/calc_increment_ens_ncio.fd/pmain.f90 create mode 100644 util/EnKF/gfs/src/calc_increment_ncio.fd/CMakeLists.txt create mode 100755 util/EnKF/gfs/src/calc_increment_ncio.fd/calc_increment_ncio.f90 create mode 100644 util/EnKF/gfs/src/recenterncio_hybgain.fd/CMakeLists.txt create mode 100644 util/EnKF/gfs/src/recenterncio_hybgain.fd/recenterncio_hybgain.f90 delete mode 100755 util/Radiance_Monitor/image_gen/ush/run_plot_v16rt0.sh rename util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/{bad_obs.f90 => low_count.f90} (50%) create mode 100644 util/netcdf_io/CMakeLists.txt create mode 100644 util/netcdf_io/calc_analysis.fd/CMakeLists.txt create mode 100644 util/netcdf_io/calc_analysis.fd/inc2anl.f90 create mode 100644 util/netcdf_io/calc_analysis.fd/init_calc_analysis.f90 create mode 100644 util/netcdf_io/calc_analysis.fd/init_io.f90 create mode 100644 util/netcdf_io/calc_analysis.fd/main.f90 create mode 100644 util/netcdf_io/calc_analysis.fd/vars_calc_analysis.f90 create mode 100644 util/netcdf_io/interp_inc.fd/CMakeLists.txt create mode 100644 util/netcdf_io/interp_inc.fd/driver.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 1f9b06cf42..bfeb9438b8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -66,10 +66,11 @@ project(GSI) 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_FV3GFS_NCIO "Build the FV3GFS_NCIO library" ON) + option(BUILD_NCIO_UTIL "Build the NCIO Utilities" 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/") @@ -95,6 +96,7 @@ project(GSI) 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/Orion.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) @@ -103,12 +105,6 @@ project(GSI) 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) find_package(OpenMP) @@ -231,12 +227,21 @@ project(GSI) find_package( SFCIO ) find_package( W3EMC ) find_package( W3NCO ) + find_package( IP ) if(BUILD_NCDIAG) set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag/include") add_subdirectory(src/ncdiag) set(NCDIAG_LIBRARIES ncdiag ) endif(BUILD_NCDIAG) + if(BUILD_FV3GFS_NCIO) + set(FV3GFS_NCIO_INCS "${PROJECT_BINARY_DIR}/libsrc/fv3gfs_ncio/include") + add_subdirectory(src/fv3gfs_ncio) + set(FV3GFS_NCIO_LIBRARIES fv3gfs_ncio ) + endif(BUILD_FV3GFS_NCIO) + if(BUILD_NCIO_UTIL) + add_subdirectory(util/netcdf_io) + endif(BUILD_NCIO_UTIL) find_package( BACIO ) find_package( BUFR ) @@ -247,6 +252,7 @@ project(GSI) find_package( SFCIO ) find_package( W3EMC ) find_package( W3NCO ) + find_package( IP ) if(BUILD_GSDCLOUD_ARW) set(GSDCLOUD_DIR "${CMAKE_SOURCE_DIR}/libsrc/GSD/gsdcloud") @@ -300,7 +306,7 @@ project(GSI) 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}/${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; + set( REG_TEST_NAMES "global_T62;global_T62_ozonly;global_4dvar_T62;global_4denvar_T126;global_fv3_4denvar_T126;;global_fv3_4denvar_C192;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}/${GSIEXEC} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/${ENKFEXEC} ${GSICONTROL} ${ENKFCONTROL} ${BASELINE_FLAG} ") diff --git a/cmake/Modules/FindHDF5.cmake b/cmake/Modules/FindHDF5.cmake index 9b8cffc460..78e3db3678 100644 --- a/cmake/Modules/FindHDF5.cmake +++ b/cmake/Modules/FindHDF5.cmake @@ -12,7 +12,6 @@ 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() diff --git a/cmake/Modules/FindIP.cmake b/cmake/Modules/FindIP.cmake new file mode 100644 index 0000000000..26ec21704e --- /dev/null +++ b/cmake/Modules/FindIP.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{IP_VER}) + set(IP_VER $ENV{IP_VER}) + STRING(REGEX REPLACE "v" "" IP_VER ${IP_VER}) +endif() + +set( NO_DEFAULT_PATH ) +if(NOT BUILD_IP ) + if(DEFINED ENV{IP_LIBd} ) + set(IP_LIBRARY $ENV{IP_LIBd} ) + message("IP library ${IP_LIBRARY} set via Environment variable") + else() + find_library( IP_LIBRARY + NAMES libip_d.a libip_i4r8.a libip_v${IP_VER}_d.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/ip/v${IP_VER} + ${COREPATH}/ip/v${IP_VER}/intel + ${COREPATH}/ip/v${IP_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( ip "ip_v${IP_VER}_d") + message("Found IP library ${IP_LIBRARY}") + endif() + if(DEFINED ENV{IP_LIB4} ) + set(IP_4_LIBRARY $ENV{IP_LIB4} ) + message("IP 4 library ${IP_4_LIBRARY} set via Environment variable") + else() + find_library( IP_4_LIBRARY + NAMES libip_4.a libip_i4r4.a libip_v${IP_VER}_4.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/ip/v${IP_VER} + ${COREPATH}/ip/v${IP_VER}/intel + ${COREPATH}/ip/v${IP_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( ip "ip_v${IP_VER}_4") + message("Found IP_4 library ${IP_4_LIBRARY}") + endif() +endif() +if( NOT IP_LIBRARY ) # didn't find the library, so build it from source + message("Could not find IP library, so building from libsrc") + if( NOT DEFINED ENV{IP_SRC} ) + findSrc( "ip" IP_VER IP_DIR ) + else() + set( IP_DIR "$ENV{IP_SRC}/libsrc" CACHE STRING "IP Source Location") + endif() + set( libsuffix "_v${IP_VER}${debug_suffix}" ) + set( IP_LIBRARY "${LIBRARY_OUTPUT_PATH}/libip${libsuffix}.a" CACHE STRING "IP Library" ) + set( IP_4_LIBRARY "${LIBRARY_OUTPUT_PATH}/libip_4${libsuffix}.a" CACHE STRING "IP_4 Library" ) + set( ip "ip${libsuffix}") + set( ip4 "ip_4${libsuffix}") + set( BUILD_IP "ON" CACHE INTERNAL "Build the IP library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/ip) + set( IP_LIBRARY ${ip} ) + set( IP_4_LIBRARY ${ip4} ) + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${IP_LIBRARY} ) + else() + set( CORE_BUILT ${IP_LIBRARY} ) + endif() +else( NOT IP_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${IP_LIBRARY} ) + else() + set( CORE_LIBRARIES ${IP_LIBRARY} ) + endif() +endif( NOT IP_LIBRARY ) + + +set( IP_LIBRARY_PATH ${IP_LIBRARY} CACHE STRING "IP Library Location" ) +set( IP_4_LIBRARY_PATH ${IP_4_LIBRARY} CACHE STRING "IP_4 Library Location" ) + diff --git a/cmake/Modules/platforms/Cheyenne.cmake b/cmake/Modules/platforms/Cheyenne.cmake index 764a2bffa2..54477168e8 100644 --- a/cmake/Modules/platforms/Cheyenne.cmake +++ b/cmake/Modules/platforms/Cheyenne.cmake @@ -6,7 +6,7 @@ macro (setCheyenne) 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(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") set(BUILD_CORELIBS "ON" ) set(BUILD_UTIL "OFF" CACHE INTERNAL "" ) diff --git a/cmake/Modules/platforms/Discover.cmake b/cmake/Modules/platforms/Discover.cmake index 54429b1a6b..fe8a2dfc0e 100644 --- a/cmake/Modules/platforms/Discover.cmake +++ b/cmake/Modules/platforms/Discover.cmake @@ -7,7 +7,7 @@ macro (setDiscover) 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(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") set(host "Discover" CACHE INTERNAL "") set(COREPATH $ENV{COREPATH} ) diff --git a/cmake/Modules/platforms/Gaea.cmake b/cmake/Modules/platforms/Gaea.cmake index d897400e6c..d6929b8f03 100644 --- a/cmake/Modules/platforms/Gaea.cmake +++ b/cmake/Modules/platforms/Gaea.cmake @@ -8,7 +8,7 @@ macro (setGaea) 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(ENKF_Platform_FLAGS "-O3 -fp-model strict -convert big_endian -assume byterecl -implicitnone -DGFS -D_REAL8_ -traceback ${HOST_FLAG} ${MKL_FLAG} ${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 index 9945c4bfd9..1e06239a4e 100644 --- a/cmake/Modules/platforms/Generic.cmake +++ b/cmake/Modules/platforms/Generic.cmake @@ -9,6 +9,6 @@ macro (setGeneric) 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") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") endmacro() diff --git a/cmake/Modules/platforms/Hera.cmake b/cmake/Modules/platforms/Hera.cmake index 9fce9a3a47..d8af27696c 100644 --- a/cmake/Modules/platforms/Hera.cmake +++ b/cmake/Modules/platforms/Hera.cmake @@ -1,12 +1,12 @@ macro (setHERA) message("Setting paths for HERA") - option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5 "Try to Find HDF5 libraries" ON) 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") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + set(HDF5_USE_STATIC_LIBRARIES "ON") if( NOT DEFINED ENV{NETCDF_VER} ) set(NETCDF_VER "3.6.3" ) diff --git a/cmake/Modules/platforms/Jet.cmake b/cmake/Modules/platforms/Jet.cmake index 8c19dd06f4..8178526d40 100644 --- a/cmake/Modules/platforms/Jet.cmake +++ b/cmake/Modules/platforms/Jet.cmake @@ -5,6 +5,6 @@ macro (setJet) 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") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") endmacro() diff --git a/cmake/Modules/platforms/Orion.cmake b/cmake/Modules/platforms/Orion.cmake new file mode 100644 index 0000000000..56ddd1f2c3 --- /dev/null +++ b/cmake/Modules/platforms/Orion.cmake @@ -0,0 +1,42 @@ +macro (setOrion) + message("Setting paths for Orion") + option(FIND_HDF5 "Try to Find HDF5 libraries" ON) + 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_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + set(HDF5_USE_STATIC_LIBRARIES "ON") + + 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/S4.cmake b/cmake/Modules/platforms/S4.cmake index 1a5fe7ec73..c727765c16 100644 --- a/cmake/Modules/platforms/S4.cmake +++ b/cmake/Modules/platforms/S4.cmake @@ -5,6 +5,6 @@ macro (setS4) 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(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") set(HDF5_USE_STATIC_LIBRARIES "OFF") endmacro() diff --git a/cmake/Modules/platforms/WCOSS-D.cmake b/cmake/Modules/platforms/WCOSS-D.cmake index ccc2a4f9ce..e0daffa593 100644 --- a/cmake/Modules/platforms/WCOSS-D.cmake +++ b/cmake/Modules/platforms/WCOSS-D.cmake @@ -1,13 +1,13 @@ macro (setWCOSS_D) message("Setting paths for Dell") - option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5 "Try to Find HDF5 libraries" ON) 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(ENKF_Platform_FLAGS "-O3 -fp-model strict -convert big_endian -assume byterecl -implicitnone -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "ENKF Fortran Flags") set(HDF5_USE_STATIC_LIBRARIES "ON" CACHE INTERNAL "" ) if( NOT DEFINED ENV{COREPATH} ) @@ -25,7 +25,7 @@ macro (setWCOSS_D) set(BACIO_VER "2.0.2" ) endif() if( NOT DEFINED ENV{BUFR_VER} ) - set(BUFR_VER "11.2.0" ) + set(BUFR_VER "11.3.0" ) endif() if( NOT DEFINED ENV{CRTM_VER} ) set(CRTM_VER "2.2.5" ) diff --git a/cmake/Modules/setHOST.cmake b/cmake/Modules/setHOST.cmake index a4f3628b30..1d0a3b5341 100644 --- a/cmake/Modules/setHOST.cmake +++ b/cmake/Modules/setHOST.cmake @@ -4,6 +4,7 @@ macro( setHOST ) string(REGEX MATCH "s4-" HOST-S4 ${HOSTNAME} ) string(REGEX MATCH "gaea" HOST-Gaea ${HOSTNAME} ) string(REGEX MATCH "hfe[0-9]" HOST-Hera ${HOSTNAME} ) + string(REGEX MATCH "Orion" HOST-Orion ${HOSTNAME} ) if(EXISTS /jetmon) set(HOST-Jet "True" ) endif() @@ -51,6 +52,11 @@ macro( setHOST ) option(BUILD_CORELIBS "Build the Core libraries " OFF) setHERA() set( HOST-Hera "TRUE" ) + elseif( HOST-Orion ) + set( host "Orion" ) + option(BUILD_CORELIBS "Build the Core libraries " OFF) + setOrion() + set( HOST-Orion "TRUE" ) elseif( HOST-Gaea ) set( host "Gaea" ) option(BUILD_CORELIBS "Build the Core libraries " On) diff --git a/cmake/Modules/setIntelFlags.cmake b/cmake/Modules/setIntelFlags.cmake index 77873550ac..70544725a3 100644 --- a/cmake/Modules/setIntelFlags.cmake +++ b/cmake/Modules/setIntelFlags.cmake @@ -20,6 +20,7 @@ function(set_LIBRARY_UTIL_Intel) 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(FV3GFS_NCIO_Fortran_FLAGS "-free" 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 "" ) @@ -45,6 +46,7 @@ function(set_LIBRARY_UTIL_Debug_Intel) 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(FV3GFS_NCIO_Fortran_FLAGS "-free" 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 "" ) @@ -63,7 +65,7 @@ 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(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_ ${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 "" ) diff --git a/cmake/Modules/setPlatformVariables.cmake b/cmake/Modules/setPlatformVariables.cmake index 728e1a3e7f..79408821a6 100644 --- a/cmake/Modules/setPlatformVariables.cmake +++ b/cmake/Modules/setPlatformVariables.cmake @@ -3,6 +3,7 @@ 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/Orion.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) diff --git a/fix b/fix index 6c7d9f470f..543c84b44d 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 6c7d9f470fba03cfc77850b9a5e49295ceb2f4b7 +Subproject commit 543c84b44d6e87df2231988a55e0d2b25b3aa042 diff --git a/jobs/JGDAS_ENKF_POST b/jobs/JGDAS_ENKF_POST index e0bcc055f9..55bb97ee14 100755 --- a/jobs/JGDAS_ENKF_POST +++ b/jobs/JGDAS_ENKF_POST @@ -65,10 +65,9 @@ fi ############################################## # Begin JOB SPECIFIC work ############################################## +export GFS_NCIO=${GFS_NCIO:-"YES"} export PREFIX="${CDUMP}.t${cyc}z." -export SUFFIX=".nemsio" - # COMIN, COMOUT are used in exglobal script # TO DO: Map NCO's directory into these variables diff --git a/jobs/JGDAS_ENKF_RECENTER b/jobs/JGDAS_ENKF_RECENTER index d291be2e6e..01c2b9cbdc 100755 --- a/jobs/JGDAS_ENKF_RECENTER +++ b/jobs/JGDAS_ENKF_RECENTER @@ -81,13 +81,12 @@ 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" +export GSUFFIX=${GSUFFIX:-$SUFFIX} +export ASUFFIX=${ASUFFIX:-$SUFFIX} if [ $RUN_ENVIR = "nco" -o ${ROTDIR_DUMP:-NO} = "YES" ]; then export COMIN_OBS=${COMIN_OBS:-$ROTDIR/$RUN.$PDY/$cyc} diff --git a/jobs/JGDAS_ENKF_SURFACE b/jobs/JGDAS_ENKF_SURFACE new file mode 100755 index 0000000000..1fe82beada --- /dev/null +++ b/jobs/JGDAS_ENKF_SURFACE @@ -0,0 +1,143 @@ +#!/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 esfc" +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 esfc +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 + + +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 GPREFIX="${CDUMP}.t${gcyc}z." +export GSUFFIX=${GSUFFIX:-$SUFFIX} +export ASUFFIX=${ASUFFIX:-$SUFFIX} + +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_ENKF.$PDY/$cyc" +export COMOUT_ENS="$ROTDIR/enkf$CDUMP.$PDY/$cyc" +export COMIN_GES_ENS="$ROTDIR/enkf$CDUMP.$gPDY/$gcyc" + + +############################################################### +# Run relevant exglobal script +env +msg="HAS BEGUN on `hostname`" +postmsg "$jlogfile" "$msg" +$LOGSCRIPT + + +${ENKFRESFCSH:-$SCRgsi/exglobal_enkf_surface_fv3gfs.sh.ecf} +status=$? +[[ $status -ne 0 ]] && exit $status + + +############################################## +# 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_ANALCALC b/jobs/JGLOBAL_ANALCALC new file mode 100755 index 0000000000..94e524a0e6 --- /dev/null +++ b/jobs/JGLOBAL_ANALCALC @@ -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 analcalc" +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 anal +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:-"gfs"}} +if [ $RUN_ENVIR = "nco" ]; then + export ROTDIR=${COMROOT:?}/$NET/$envir +fi +export DO_CALC_ANALYSIS=${DO_CALC_ANALYSIS:-"YES"} + + +############################################## +# 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 OPREFIX="${CDUMP}.t${cyc}z." +export GPREFIX="${GDUMP}.t${gcyc}z." +export APREFIX="${CDUMP}.t${cyc}z." +export GSUFFIX=${GSUFFIX:-$SUFFIX} +export ASUFFIX=${ASUFFIX:-$SUFFIX} + + +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/$GDUMP.$gPDY/$gcyc" +export COMIN_GES_ENS="$ROTDIR/enkfgdas.$gPDY/$gcyc" + + +export ATMGES="$COMIN_GES/${GPREFIX}atmf006${GSUFFIX}" +if [ ! -f $ATMGES ]; then + echo "FATAL ERROR: FILE MISSING: ATMGES = $ATMGES" + exit 1 +fi + + +# Get LEVS +if [ ${GSUFFIX} = ".nc" ]; then + export LEVS=$($NCLEN $ATMGES pfull) + status=$? +else + export LEVS=$($NEMSIOGET $ATMGES dimz | awk '{print $2}') + status=$? +fi +[[ $status -ne 0 ]] && exit $status + + +if [ $DOHYBVAR = "YES" ]; then + 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 2 + fi +fi + + + +# Update surface fields with global_cycle +export DOGCYCLE=${DOGCYCLE:-"YES"} + + +# Generate Gaussian surface analysis +export DOGAUSFCANL=${DOGAUSFCANL:-"YES"} + + +############################################################### +# Run relevant exglobal script +env +msg="HAS BEGUN on `hostname`" +postmsg "$jlogfile" "$msg" +$LOGSCRIPT + + +${ANALCALCSH:-$HOMEgsi/scripts/exglobal_analcalc_fv3gfs.sh.ecf} +status=$? +[[ $status -ne 0 ]] && exit $status + + +############################################## +# 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_ANALDIAG b/jobs/JGLOBAL_ANALDIAG new file mode 100755 index 0000000000..0dc227616a --- /dev/null +++ b/jobs/JGLOBAL_ANALDIAG @@ -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 analdiag" +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 anal +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:-"gfs"}} +if [ $RUN_ENVIR = "nco" ]; then + export ROTDIR=${COMROOT:?}/$NET/$envir +fi +export DO_CALC_ANALYSIS=${DO_CALC_ANALYSIS:-"YES"} + + +############################################## +# 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 OPREFIX="${CDUMP}.t${cyc}z." +export GPREFIX="${GDUMP}.t${gcyc}z." +export APREFIX="${CDUMP}.t${cyc}z." +export GSUFFIX=${GSUFFIX:-$SUFFIX} +export ASUFFIX=${ASUFFIX:-$SUFFIX} + + +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/$GDUMP.$gPDY/$gcyc" +export COMIN_GES_ENS="$ROTDIR/enkfgdas.$gPDY/$gcyc" + + +export ATMGES="$COMIN_GES/${GPREFIX}atmf006${GSUFFIX}" +if [ ! -f $ATMGES ]; then + echo "FATAL ERROR: FILE MISSING: ATMGES = $ATMGES" + exit 1 +fi + + +# Get LEVS +if [ ${GSUFFIX} = ".nc" ]; then + export LEVS=$($NCLEN $ATMGES pfull) + status=$? +else + export LEVS=$($NEMSIOGET $ATMGES dimz | awk '{print $2}') + status=$? +fi +[[ $status -ne 0 ]] && exit $status + + +if [ $DOHYBVAR = "YES" ]; then + 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 2 + fi +fi + + + +# Update surface fields with global_cycle +export DOGCYCLE=${DOGCYCLE:-"YES"} + + +# Generate Gaussian surface analysis +export DOGAUSFCANL=${DOGAUSFCANL:-"YES"} + + +############################################################### +# Run relevant exglobal script +env +msg="HAS BEGUN on `hostname`" +postmsg "$jlogfile" "$msg" +$LOGSCRIPT + + +${ANALDIAGSH:-$HOMEgsi/scripts/exglobal_analdiag_fv3gfs.sh.ecf} +status=$? +[[ $status -ne 0 ]] && exit $status + + +############################################## +# 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_ANALYSIS b/jobs/JGLOBAL_ANALYSIS index 68883059cf..2933109c91 100755 --- a/jobs/JGLOBAL_ANALYSIS +++ b/jobs/JGLOBAL_ANALYSIS @@ -61,6 +61,7 @@ export CDUMP=${CDUMP:-${RUN:-"gfs"}} if [ $RUN_ENVIR = "nco" ]; then export ROTDIR=${COMROOT:?}/$NET/$envir fi +export DO_CALC_ANALYSIS=${DO_CALC_ANALYSIS:-"YES"} ############################################## @@ -74,9 +75,9 @@ GDUMP=${GDUMP:-"gdas"} export OPREFIX="${CDUMP}.t${cyc}z." export GPREFIX="${GDUMP}.t${gcyc}z." -export GSUFFIX=".nemsio" export APREFIX="${CDUMP}.t${cyc}z." -export ASUFFIX=".nemsio" +export GSUFFIX=${GSUFFIX:-$SUFFIX} +export ASUFFIX=${ASUFFIX:-$SUFFIX} if [ $RUN_ENVIR = "nco" -o ${ROTDIR_DUMP:-NO} = "YES" ]; then @@ -103,8 +104,14 @@ if [ ! -f $ATMGES ]; then fi -export LEVS=$($NEMSIOGET $ATMGES dimz | awk '{print $2}') -status=$? +# Get LEVS +if [ ${GSUFFIX} = ".nc" ]; then + export LEVS=$($NCLEN $ATMGES pfull) + status=$? +else + export LEVS=$($NEMSIOGET $ATMGES dimz | awk '{print $2}') + status=$? +fi [[ $status -ne 0 ]] && exit $status diff --git a/jobs/JGLOBAL_ENKF_ANALDIAG b/jobs/JGLOBAL_ENKF_ANALDIAG new file mode 100755 index 0000000000..6e08ea2f47 --- /dev/null +++ b/jobs/JGLOBAL_ENKF_ANALDIAG @@ -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 ediag" +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 GPREFIX="${GDUMP}.t${gcyc}z." +export GSUFFIX="${GSUFFIX:-".ensmean${SUFFIX}"}" +export ASUFFIX="${ASUFFIX:-"${SUFFIX}"}" + +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=$($NCDUMP -h $ATMGES_ENSMEAN | grep -i "pfull" | head -1 | awk -F" = " '{print $2}' | awk -F" " '{print $1}') # get LEVS +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" +export DIAG_COMPRESS="NO" + +# GSI namelist options specific to eobs +export SETUP_INVOBS="passive_bc=.false.,$SETUP_INVOBS" + +# 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 + + +${ANALDIAGSH:-$SCRgsi/exglobal_analdiag_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_INNOVATE_OBS b/jobs/JGLOBAL_ENKF_INNOVATE_OBS index b38fe48a49..19ce533984 100755 --- a/jobs/JGLOBAL_ENKF_INNOVATE_OBS +++ b/jobs/JGLOBAL_ENKF_INNOVATE_OBS @@ -73,12 +73,11 @@ 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" +export GSUFFIX="${GSUFFIX:-$SUFFIX}" +export ASUFFIX="${ASUFFIX:-$SUFFIX}" # COMIN_GES, COMIN_GES_ENS and COMOUT are used in exglobal script @@ -96,7 +95,7 @@ if [ ! -f $ATMGES_ENSMEAN ]; then fi -export LEVS=$($NEMSIOGET $ATMGES_ENSMEAN dimz | awk '{print $2}') +export LEVS=$($NCDUMP -h $ATMGES_ENSMEAN | grep -i "pfull" | head -1 | awk -F" = " '{print $2}' | awk -F" " '{print $1}') # get LEVS status=$? [[ $status -ne 0 ]] && exit $status diff --git a/jobs/JGLOBAL_ENKF_SELECT_OBS b/jobs/JGLOBAL_ENKF_SELECT_OBS index ce98032f05..de69dd94b0 100755 --- a/jobs/JGLOBAL_ENKF_SELECT_OBS +++ b/jobs/JGLOBAL_ENKF_SELECT_OBS @@ -74,12 +74,11 @@ 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" +export GSUFFIX="${GSUFFIX:-".ensmean${SUFFIX}"}" +export ASUFFIX="${ASUFFIX:-"${SUFFIX}"}" if [ $RUN_ENVIR = "nco" -o ${ROTDIR_DUMP:-NO} = "YES" ]; then export COMIN_OBS=${COMIN_OBS:-$ROTDIR/$RUN.$PDY/$cyc} @@ -104,7 +103,7 @@ if [ ! -f $ATMGES_ENSMEAN ]; then exit 1 fi -export LEVS=$($NEMSIOGET $ATMGES_ENSMEAN dimz | awk '{print $2}') +export LEVS=$($NCDUMP -h $ATMGES_ENSMEAN | grep -i "pfull" | head -1 | awk -F" = " '{print $2}' | awk -F" " '{print $1}') # get LEVS status=$? [[ $status -ne 0 ]] && exit $status @@ -145,7 +144,7 @@ export SELECT_OBS="$COMOUT/${APREFIX}obsinput.ensmean" export DIAG_SUFFIX="_ensmean" # GSI namelist options specific to eobs -export SETUP_INVOBS="passive_bc=.false." +export SETUP_INVOBS="passive_bc=.false.,$SETUP_INVOBS" # Ensure clean stat tarballs for ensemble mean for fstat in $CNVSTAT $OZNSTAT $RADSTAT; do diff --git a/jobs/JGLOBAL_ENKF_UPDATE b/jobs/JGLOBAL_ENKF_UPDATE index 119a8c446c..b66b7e2870 100755 --- a/jobs/JGLOBAL_ENKF_UPDATE +++ b/jobs/JGLOBAL_ENKF_UPDATE @@ -70,11 +70,10 @@ 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" +export ASUFFIX=${ASUFFIX:-$SUFFIX} +export GSUFFIX=${GSUFFIX:-$SUFFIX} # COMIN_GES_ENS and COMOUT_ANL_ENS are used in exglobal script diff --git a/modulefiles/modulefile.ProdGSI.hera b/modulefiles/modulefile.ProdGSI.hera index 8cd2cf4bd4..b2ac092ced 100644 --- a/modulefiles/modulefile.ProdGSI.hera +++ b/modulefiles/modulefile.ProdGSI.hera @@ -14,11 +14,15 @@ set C_COMP_MP mpcc # Known conflicts + # Load compiler, mpi, cmake, and hdf5/netcdf module load intel/18.0.5.274 +# python +module use -a /contrib/modulefiles +module load anaconda/2.3.0 + 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 @@ -26,7 +30,8 @@ module load cmake/3.9.0 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 crtm/2.3.0 +module load ip/3.0.2 module load nemsio/2.2.4 module load prod_util/1.1.0 module load sfcio/1.1.1 @@ -34,7 +39,10 @@ module load sigio/2.1.1 module load sp/2.0.3 module load w3emc/2.3.1 module load w3nco/2.0.7 +module load hdf5_parallel/1.10.6 +module load netcdf_parallel/4.7.4 # 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.orion b/modulefiles/modulefile.ProdGSI.orion new file mode 100644 index 0000000000..db8a9f4c7f --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.orion @@ -0,0 +1,46 @@ +#%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/2018.4 +module load impi/2018.4 + +module load cmake/3.15.4 + +# Python +module load python/3.7.5 + +# Load libraries +module use /apps/contrib/NCEPLIBS/orion/modulefiles +module load bacio/2.0.3 +module load crtm/2.3.0 +module load ip/3.1.0 +module load nemsio/2.3.0 +module load prod_util/1.2.0 +module load sfcio/1.2.0 +module load sigio/2.2.0 +module load sp/2.1.0 +module load w3emc/2.5.0 +module load w3nco/2.1.0 +module load bufr/11.3.0 +module load netcdf_parallel/4.7.4 +module load hdf5_parallel/1.10.6 + +# Fix MKL threads for reproducible global_gsi.x with correlated obs error +#export MKL_NUM_THREADS=4 +#export MKL_CBWR=AUTO + diff --git a/modulefiles/modulefile.ProdGSI.wcoss_c b/modulefiles/modulefile.ProdGSI.wcoss_c index bd47ab1403..8a2ec237ec 100644 --- a/modulefiles/modulefile.ProdGSI.wcoss_c +++ b/modulefiles/modulefile.ProdGSI.wcoss_c @@ -48,21 +48,25 @@ 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 +module load cray-netcdf/4.3.2 +module load cray-hdf5/1.8.14 # Loading nceplibs modules module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles module load bufr-intel/11.0.1 +module load ip-intel/3.0.0 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 +module use -a /usrx/local/nceplibs/NCEPLIBS/modulefiles +module load crtm/2.3.0 + +# Loading python +module load python/3.6.3 diff --git a/modulefiles/modulefile.ProdGSI.wcoss_d b/modulefiles/modulefile.ProdGSI.wcoss_d index 2bf614b4f4..69fe0a4108 100644 --- a/modulefiles/modulefile.ProdGSI.wcoss_d +++ b/modulefiles/modulefile.ProdGSI.wcoss_d @@ -32,18 +32,25 @@ module load impi/18.0.1 module load prod_util/1.1.0 # Loading nceplibs modules -module load bufr/11.2.0 +module load bufr/11.3.0 +module load ip/3.0.1 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 + +# Loading python +module load python/3.6.3 + +# Load modules from nceplibs (until installed by NCO) +module use -a /usrx/local/nceplibs/dev/NCEPLIBS/modulefiles +module load crtm/2.3.0 +module load hdf5_parallel/1.10.6 +module load netcdf_parallel/4.7.4 + diff --git a/regression/global_4denvar_T126.sh b/regression/global_4denvar_T126.sh index f926517dea..02ca7f8e54 100755 --- a/regression/global_4denvar_T126.sh +++ b/regression/global_4denvar_T126.sh @@ -224,6 +224,7 @@ scaninfo=$fixgsi/global_scaninfo.txt satinfo=$fixgsi/global_satinfo.txt cloudyinfo=$fixgsi/cloudy_radiance_info.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat insituinfo=$fixgsi/global_insituinfo.txt ### add 9 tables errtable_pw=$fixgsi/prepobs_errtable_pw.global @@ -276,6 +277,7 @@ $ncp $cloudyinfo ./cloudy_radiance_info.txt $ncp $pcpinfo ./pcpinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $insituinfo ./insituinfo $ncp $errtable ./errtable $ncp $anavinfo ./anavinfo @@ -352,6 +354,7 @@ $ncp $global_4denvar_T126_datobs/atms.gdas.$global_4denvar_T126_adate $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 +$ncp $global_4denvar_T126_datobs/ahicsr.gdas.$global_4denvar_T126_adate ./ahibufr # Copy bias correction, atmospheric and surface files diff --git a/regression/global_4dvar_T62.sh b/regression/global_4dvar_T62.sh index 5b13542b76..795008c04b 100755 --- a/regression/global_4dvar_T62.sh +++ b/regression/global_4dvar_T62.sh @@ -236,6 +236,7 @@ atmsbeamdat=$fixgsi/atms_beamwidth.txt pcpinfo=$fixgsi/global_pcpinfo.txt ozinfo=$fixgsi/global_ozinfo.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat errtable=$fixgsi/prepobs_errtable.global ### add 9 tables errtable_pw=$fixgsi/prepobs_errtable_pw.global @@ -283,6 +284,7 @@ $ncp $scaninfo ./scaninfo $ncp $pcpinfo ./pcpinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $errtable ./errtable #add 9 tables for new varqc $ncp $errtable_pw ./errtable_pw diff --git a/regression/global_T62.sh b/regression/global_T62.sh index 5ac99cdcae..fded077a26 100755 --- a/regression/global_T62.sh +++ b/regression/global_T62.sh @@ -233,6 +233,7 @@ scaninfo=$fixgsi/global_scaninfo.txt satinfo=$fixgsi/global_satinfo.txt cloudyinfo=$fixgsi/cloudy_radiance_info.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat anavinfo=$fixgsi/global_anavinfo.l64.txt ozinfo=$fixgsi/global_ozinfo.txt pcpinfo=$fixgsi/global_pcpinfo.txt @@ -282,6 +283,7 @@ $ncp $cloudyinfo ./cloudy_radiance_info.txt $ncp $pcpinfo ./pcpinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $errtable ./errtable $ncp $anavinfo ./anavinfo $ncp $hybens_info ./hybens_info diff --git a/regression/global_T62_ozonly.sh b/regression/global_T62_ozonly.sh index 8fb9e3d3d8..4d2ee6a4d6 100755 --- a/regression/global_T62_ozonly.sh +++ b/regression/global_T62_ozonly.sh @@ -229,6 +229,7 @@ scaninfo=$fixgsi/global_scaninfo.txt satinfo=$fixgsi/global_satinfo.txt cloudyinfo=$fixgsi/cloudy_radiance_info.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat anavinfo=$fixgsi/global_anavinfo_ozonly.l64.txt ozinfo=$fixgsi/global_ozinfo.txt pcpinfo=$fixgsi/global_pcpinfo.txt @@ -279,6 +280,7 @@ $ncp $cloudyinfo ./cloudy_radiance_info.txt $ncp $pcpinfo ./pcpinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $errtable ./errtable $ncp $anavinfo ./anavinfo $ncp $hybens_info ./hybens_info diff --git a/regression/global_enkf_T62.sh b/regression/global_enkf_T62.sh index 54c75dbab0..23b4026884 100755 --- a/regression/global_enkf_T62.sh +++ b/regression/global_enkf_T62.sh @@ -100,6 +100,7 @@ satangl=$fixgsi/global_satangbias.txt scaninfo=$fixgsi/global_scaninfo.txt satinfo=$fixgsi/global_satinfo.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat ozinfo=$fixgsi/global_ozinfo.txt hybens_info=$fixgsi/global_hybens_info.l64.txt anavinfo=$fixgsi/global_anavinfo.l64.txt @@ -128,6 +129,7 @@ $ncp $scaninfo ./scaninfo $ncp $satinfo ./satinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $hybens_info ./hybens_info $ncp $anavinfo ./anavinfo diff --git a/regression/global_fv3_4denvar_C192.sh b/regression/global_fv3_4denvar_C192.sh new file mode 100755 index 0000000000..ffc9a2ba79 --- /dev/null +++ b/regression/global_fv3_4denvar_C192.sh @@ -0,0 +1,425 @@ + +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. +export JCAP=190 +export LEVS=127 +export JCAP_B=382 +export JCAP_EN=190 + +# 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" = "190" ]]; then + export LONA=384 + export LATA=192 + export DELTIM=400 + 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_C192_adate | cut -c1-8` +cyc=`echo $global_fv3_4denvar_C192_adate | cut -c9-10` +GDATE=`$ndate -06 $global_fv3_4denvar_C192_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_C192_datobs/gdas.$PDY/$cyc +datanl=$global_fv3_4denvar_C192_datobs/gdas.$PDY/$cyc +datges=$global_fv3_4denvar_C192_datges/gdas.$gPDY/$gcyc +datens=$global_fv3_4denvar_C192_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_C192_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_C192_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_C192_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_C192_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_C192 +else + . $scripts/regression_namelists_db.sh global_fv3_4denvar_C192 +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.) + +anavinfo=$fixgsi/global_anavinfo.l${LEVS}.txt +berror=$fixgsi/Big_Endian/global_berror.l${LEVS}y${NLAT}.f77 +locinfo=$fixgsi/global_hybens_info.l${LEVS}.txt +satinfo=$fixgsi/global_satinfo.txt +scaninfo=$fixgsi/global_scaninfo.txt +satangl=$fixgsi/global_satangbias.txt +pcpinfo=$fixgsi/global_pcpinfo.txt +ozinfo=$fixgsi/global_ozinfo.txt +convinfo=$fixgsi/global_convinfo.txt +vqcdat=$fixgsi/vqctp001.dat +insituinfo=$fixgsi/global_insituinfo.txt +errtable=$fixgsi/prepobs_errtable.global +aeroinfo=$fixgsi/global_aeroinfo.txt +atmsbeaminfo=$fixgsi/atms_beamwidth.txt +cloudyinfo=$fixgsi/cloudy_radiance_info.txt + +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 + +# 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 $anavinfo ./anavinfo +$ncp $berror ./berror_stats +$ncp $locinfo ./hybens_info +$ncp $satinfo ./satinfo +$ncp $scaninfo ./scaninfo +$ncp $pcpinfo ./pcpinfo +$ncp $ozinfo ./ozinfo +$ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat +$ncp $insituinfo ./insituinfo +$ncp $errtable ./errtable +$ncp $aeroinfo ./aeroinfo +$ncp $atmsbeaminfo ./atms_beamwidth.txt +$ncp $cloudyinfo ./cloudy_radiance_info.txt + +$ncp $bufrtable ./prepobs_prep.bufrtable +$ncp $bftab_sst ./bftab_sstphr + +#If using correlated error, get the covariance files +if grep -q "Rcov" $anavinfo ; +then + if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; + then + $ncp ${fixgsi}/Rcov* $tmpdir/ + +# Correlated error utlizes mkl lapack. Found it necesary to fix the +# number of mkl threads to ensure reproducible results independent +# of the job configuration. + export MKL_NUM_THREADS=1 + + 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 +mkdir -p crtm_coeffs +for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do + $ncp $fixcrtm/${file}.SpcCoeff.bin ./crtm_coeffs/ + $ncp $fixcrtm/${file}.TauCoeff.bin ./crtm_coeffs/ +done + +$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 + + +# 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}.ompsn8.${suffix} ./ompsnpbufr +$ncpl $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr +$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.nc ./sfcf$fh + $ncpl $datges/${prefix_ges}.atmf0$fh.nc ./sigf$fh +done + + +ensemble_path="./ensemble_data/" +mkdir -p $ensemble_path +enkf_suffix="" +flist="03 04 05 06 07 08 09" +for fh in $flist; do + sigens=${prefix_ens}.atmf0${fh}${enkf_suffix}.nc + + 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.nc ./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_fv3_4denvar_T126.sh b/regression/global_fv3_4denvar_T126.sh index ae02aee52d..0f79fabe3e 100755 --- a/regression/global_fv3_4denvar_T126.sh +++ b/regression/global_fv3_4denvar_T126.sh @@ -239,6 +239,7 @@ scaninfo=$fixgsi/global_scaninfo.txt satinfo=$fixgsi/global_satinfo.txt cloudyinfo=$fixgsi/cloudy_radiance_info.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat insituinfo=$fixgsi/global_insituinfo.txt ### add 9 tables errtable_pw=$fixgsi/prepobs_errtable_pw.global @@ -291,6 +292,7 @@ $ncp $cloudyinfo ./cloudy_radiance_info.txt $ncp $pcpinfo ./pcpinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $insituinfo ./insituinfo $ncp $errtable ./errtable $ncp $anavinfo ./anavinfo @@ -316,6 +318,12 @@ then if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; then $ncp ${fixgsi}/Rcov* . + +# Correlated error utlizes mkl lapack. Found it necesary to fix the +# number of mkl threads to ensure reproducible results independent +# of the job configuration. + export MKL_NUM_THREADS=1 + else echo "Warning: Satellite error covariance files are missing." echo "Check for the required Rcov files in " $anavinfo diff --git a/regression/global_hybrid_T126.sh b/regression/global_hybrid_T126.sh index 05486987e0..82d10e0852 100755 --- a/regression/global_hybrid_T126.sh +++ b/regression/global_hybrid_T126.sh @@ -221,6 +221,7 @@ scaninfo=$fixgsi/global_scaninfo.txt satinfo=$fixgsi/global_satinfo.txt cloudyinfo=$fixgsi/cloudy_radiance_info.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat ### add 9 tables errtable_pw=$fixgsi/prepobs_errtable_pw.global errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf @@ -270,6 +271,7 @@ $ncp $cloudyinfo ./cloudy_radiance_info.txt $ncp $pcpinfo ./pcpinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $errtable ./errtable $ncp $anavinfo ./anavinfo $ncp $hybens_info ./hybens_info diff --git a/regression/global_lanczos_T62.sh b/regression/global_lanczos_T62.sh index 9a9c376945..3b8b0876d4 100755 --- a/regression/global_lanczos_T62.sh +++ b/regression/global_lanczos_T62.sh @@ -213,6 +213,7 @@ atmsbeamdat=$fixgsi/atms_beamwidth.txt pcpinfo=$fixgsi/global_pcpinfo.txt ozinfo=$fixgsi/global_ozinfo.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat ### add 9 tables errtable_pw=$fixgsi/prepobs_errtable_pw.global errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf @@ -260,6 +261,7 @@ $ncp $scaninfo ./scaninfo $ncp $pcpinfo ./pcpinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $errtable ./errtable #add 9 tables for new varqc $ncp $errtable_pw ./errtable_pw diff --git a/regression/global_nemsio_T62.sh b/regression/global_nemsio_T62.sh index 676db8d64b..f597c6420a 100755 --- a/regression/global_nemsio_T62.sh +++ b/regression/global_nemsio_T62.sh @@ -216,6 +216,7 @@ atmsbeamdat=$fixgsi/atms_beamwidth.txt pcpinfo=$fixgsi/global_pcpinfo.txt ozinfo=$fixgsi/global_ozinfo.txt convinfo=$fixgsi/global_convinfo_reg_test.txt +vqcdat=$fixgsi/vqctp001.dat ### add 9 tables errtable_pw=$fixgsi/prepobs_errtable_pw.global errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf @@ -263,6 +264,7 @@ $ncp $scaninfo ./scaninfo $ncp $pcpinfo ./pcpinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo +$ncp $vqcdat ./vqctp001.dat $ncp $errtable ./errtable #add 9 tables for new varqc $ncp $errtable_pw ./errtable_pw diff --git a/regression/multi_regression.sh b/regression/multi_regression.sh index 5907ee08fc..fc19da4c6d 100755 --- a/regression/multi_regression.sh +++ b/regression/multi_regression.sh @@ -5,6 +5,7 @@ regtests_all="global_T62 global_4dvar_T62 global_4denvar_T126 global_fv3_4denvar_T126 + global_fv3_4denvar_C192 global_lanczos_T62 arw_netcdf arw_binary @@ -22,6 +23,7 @@ regtests_debug="global_T62 global_4dvar_T62 global_4denvar_T126 global_fv3_4denvar_T126 + global_fv3_4denvar_C192 global_lanczos_T62 arw_netcdf arw_binary diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index b80672e192..37e07a67d6 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -133,6 +133,7 @@ OBS_INPUT:: 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 + ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 :: &SUPEROB_RADAR $SUPERRAD @@ -379,6 +380,7 @@ OBS_INPUT:: 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 + ahibufr ahi himawari8 ahi_himawari8 0.0 7 0 :: &SUPEROB_RADAR $SUPERRAD @@ -541,8 +543,10 @@ 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 + 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 + ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 :: &SUPEROB_RADAR $SUPERRAD @@ -718,11 +722,11 @@ OBS_INPUT:: 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 abibufr abi g16 abi_g16 0.0 1 0 + ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 :: &SUPEROB_RADAR $SUPERRAD @@ -879,6 +883,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 @@ -904,7 +909,8 @@ OBS_INPUT:: 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 + abibufr abi g16 abi_g16 0.0 1 0 + ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 rapidscatbufr uv null uv 0.0 0 0 :: &SUPEROB_RADAR @@ -936,6 +942,209 @@ OBS_INPUT:: $NST / " +;; + + global_fv3_4denvar_C192 ) + +# 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.0002,deltim=400 + iguess=-1, + oneobtest=.false.,retrieval=.false.,l_foto=.false., + use_pbl=.false.,use_compress=.true.,nsig_ext=56,gpstop=55., + use_gfs_nemsio=.false.,lrun_subdirs=.true.,use_readin_anl_sfcmask=.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.,thin4d=.true.,cwoption=3, + verbose=.false.,imp_physics=11,lupp=.true., + binary_diag=.false.,netcdf_diag=.true., + lobsdiag_forenkf=.false., + nhr_anal=3,6,9, + l4densvar=.true.,ens_nstarthr=3,nhr_obsbin=1,nhr_assimilation=6,lwrite4danl=.true., + tzr_qc=1,sfcnst_comb=.true., + write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc',incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc', + incvars_efold=5, + use_gfs_ncio=.true., + $SETUP + / + &GRIDOPTS + JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, + regional=.false., + $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=5.0e7, + 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=.false., + aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true. + nvqc=.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 + 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 + 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 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 + avhambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 + avhpmbufr avhrr n19 avhrr3_n19 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 1 0 + abibufr abi g16 abi_g16 0.0 1 0 + abibufr abi g17 abi_g17 0.0 1 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 + iasibufr iasi metop-c iasi_metop-c 0.0 1 1 + ompslpbufr ompslp npp ompslp_npp 0.0 1 1 +:: + &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=190, + nlat_ens=194,nlon_ens=384,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) @@ -2591,6 +2800,8 @@ export gsi_namelist=" 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', + sattypes_rad(64)= 'abi_g16', dsis(64)= 'abi_g16', + sattypes_rad(65)= 'ahi_himawari8', dsis(65)= 'ahi_himawari8', $SATOBS_ENKF / &ozobs_enkf diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index 96165188ce..2b0d3fb39f 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -864,6 +864,206 @@ OBS_INPUT:: $NST / " +;; + + global_fv3_4denvar_C192 ) + +# Define namelist for global hybrid run + +export gsi_namelist=" + + &SETUP + miter=1,niter(1)=2,niter(2)=5, + niter_no_qc(1)=1,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.0002,deltim=400, + iguess=-1, + oneobtest=.false.,retrieval=.false.,l_foto=.false., + use_pbl=.false.,use_compress=.true.,nsig_ext=55,gpstop=55., + use_gfs_nemsio=.false.,use_gfs_ncio=.true.,lrun_subdirs=.true.,use_readin_anl_sfcmask=.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.,thin4d=.true.,cwoption=3, + verbose=.false.,imp_physics=11,lupp=.true.,binary_diag=.false.,netcdf_diag=.true., + lobsdiag_forenkf=.false., + nhr_anal=3,6,9, + l4densvar=.true.,ens_nstarthr=3,nhr_obsbin=1,nhr_assimilation=6,lwrite4danl=.true., tzr_qc=1,sfcnst_comb=.true., + write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc',incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc', + incvars_efold=5, + use_gfs_ncio=.true., + $SETUP + / + &GRIDOPTS + JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, + regional=.false., + $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=5.0e7,ljc4tlevs=.true., + $JCOPTS + / + &STRONGOPTS + tlnmc_option=2,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=.false., + aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true. + nvqc=.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 + 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_skip 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 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 + avhambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 + avhpmbufr avhrr n19 avhrr3_n19 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 1 0 + abibufr abi g16 abi_g16 0.0 1 0 + abibufr abi g17 abi_g17 0.0 1 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 + iasibufr iasi metop-c iasi_metop-c 0.0 1 1 + ompslpbufr ompslp npp ompslp_npp 0.0 1 1 +:: + &SUPEROB_RADAR + $SUPERRAD + / + &LAG_DATA + $LAGDATA + / + &HYBRID_ENSEMBLE + l_hyb_ens=.true.,n_ens=10,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=190, + nlat_ens=194,nlon_ens=384,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) diff --git a/regression/regression_nl_update.sh b/regression/regression_nl_update.sh index 81be5c2447..d8d52b2169 100755 --- a/regression/regression_nl_update.sh +++ b/regression/regression_nl_update.sh @@ -28,11 +28,8 @@ export BKGVERR_update="" export ANBKGERR_update="" export JCOPTS_update="" if [[ `expr substr $exp 1 6` = "global" ]]; then - if [[ `expr substr $exp $((${#exp}-4)) ${#exp}` = "updat" ]]; then - export STRONGOPTS_update="" - else - export STRONGOPTS_update="" - fi + export STRONGOPTS_update="" + export OBSQC_update="vqc=.false.,nvqc=.true.," fi export OBSINPUT_update="" export SUPERRAD_update="" diff --git a/regression/regression_param.sh b/regression/regression_param.sh index ba6aeb8917..3d1e30e647 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -152,7 +152,7 @@ case $regtest in popts[1]="48/12/" topts[1]="3:00:00" elif [[ "$machine" = "WCOSS_D" ]]; then - popts[1]="56/14/" + popts[1]="28/4/" topts[1]="3:00:00" fi fi @@ -254,6 +254,36 @@ case $regtest in ;; + global_fv3_4denvar_C192) + + 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 + topts[1]="1:30:00" + fi + + scaling[1]=10; scaling[2]=8; scaling[3]=4 + + ;; + global_lanczos_T62) if [[ "$machine" = "Hera" ]]; then diff --git a/regression/regression_test.sh b/regression/regression_test.sh index 1fa5c2706a..f9a736c05b 100755 --- a/regression/regression_test.sh +++ b/regression/regression_test.sh @@ -49,6 +49,7 @@ for exp in $list; do $ncp $savdir/$exp/siginc ./siginc.$exp $ncp $savdir/$exp/wrf_inout ./wrf_inout.$exp $ncp $savdir/$exp/wrf_inout06 ./wrf_inout06.$exp + $ncp $savdir/$exp/siginc.nc ./siginc.nc.$exp done # Grep out penalty/gradient information, run time, and maximum resident memory from stdout file @@ -317,7 +318,7 @@ else fi } >> $output - else + elif [[ -f siganl.${exp1} ]]; then { if cmp -s siganl.${exp1} siganl.${exp2} @@ -332,6 +333,22 @@ else failed_test=1 fi +} >> $output + elif [[ -f siginc.nc.${exp1} ]] ; then +{ +ncdump siginc.nc.${exp1} > siginc.nc.${exp1}.out +ncdump siginc.nc.${exp2} > siginc.nc.${exp2}.out +if diff -s siginc.nc.${exp1}.out siginc.nc.${exp2}.out +then + echo 'The results between the two runs ('${exp1}' and '${exp2}') are reproducible' + echo 'since the corresponding results are identical.' + echo +else + echo 'The results between the two runs ('${exp1}' and '${exp2}') are not reproducible' + echo 'Thus, the case has Failed siganl of the regression tests.' + echo + failed_test=1 +fi } >> $output fi fi @@ -433,7 +450,7 @@ elif [[ `expr substr $exp1 1 6` = "global" ]]; then fi } >> $output - else + elif [[ -f siganl.${exp1} ]]; then { @@ -450,6 +467,25 @@ elif [[ `expr substr $exp1 1 6` = "global" ]]; then fi } >> $output + elif [[ -f siginc.nc.${exp1} ]]; then + +{ + ncdump siginc.nc.${exp1} > siginc.nc.${exp1}.out + ncdump siginc.nc.${exp3} > siginc.nc.${exp3}.out + + if diff -s siginc.nc.${exp1}.out siginc.nc.${exp3}.out + then + echo 'The results between the two runs ('${exp1}' and '${exp3}') are reproducible' + echo 'since the corresponding results are identical.' + echo + else + echo 'The results between the two runs ('${exp1}' and '${exp3}') are not reproducible' + echo 'Thus, the case has Failed siganl of the regression tests.' + echo + failed_test=1 + fi +} >> $output + fi fi diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 1017fb4e9a..e6e5c4744c 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -220,6 +220,7 @@ export global_4dvar_T62_adate="2014080400" export global_hybrid_T126_adate="2014092912" export global_4denvar_T126_adate="2019041500" export global_fv3_4denvar_T126_adate="2018110500" +export global_fv3_4denvar_C192_adate="2019061006" export global_enkf_T62_adate="2014092912" export global_lanczos_T62_adate="2014080400" export global_nemsio_T62_adate="2013011400" @@ -243,6 +244,8 @@ export global_4denvar_T126_datges="$casesdir/global/sigmap/$global_4denvar_T126_ 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_fv3_4denvar_C192_datges="$casesdir/global/fv3/$global_fv3_4denvar_C192_adate" +export global_fv3_4denvar_C192_datobs=$global_fv3_4denvar_C192_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/new_obs" export global_enkf_T62_datges="$casesdir/global/sigmap/$global_enkf_T62_adate/ges" diff --git a/scripts/exglobal_analcalc_fv3gfs.sh.ecf b/scripts/exglobal_analcalc_fv3gfs.sh.ecf new file mode 100755 index 0000000000..c40b7c9783 --- /dev/null +++ b/scripts/exglobal_analcalc_fv3gfs.sh.ecf @@ -0,0 +1,245 @@ +#!/bin/ksh +################################################################################ +#### UNIX Script Documentation Block +# . . +# Script name: exglobal_anlcalc_fv3gfs.sh.ecf.sh +# Script description: Runs non-diagnostic file tasks after GSI analysis is performed +# +# Author: Cory Martin Org: NCEP/EMC Date: 2020-03-03 +# +# Abstract: This script wraps up analysis-related tasks after GSI exits successfully +# +# $Id$ +# +# Attributes: +# Language: POSIX shell +# Machine: WCOSS-Dell / Hera +# +################################################################################ + +# Set environment. +export VERBOSE=${VERBOSE:-"YES"} +if [ $VERBOSE = "YES" ]; then + echo $(date) EXECUTING $0 $* >&2 + set -x +fi + +# Directories. +pwd=$(pwd) +export NWPROD=${NWPROD:-$pwd} +export HOMEgfs=${HOMEgfs:-$NWPROD} +export HOMEgsi=${HOMEgsi:-$NWPROD} +export FIXgsm=${FIXgsm:-$HOMEgfs/fix/fix_am} +export DATA=${DATA:-$pwd/anlcalc.$$} +export COMIN=${COMIN:-$pwd} +export COMIN_OBS=${COMIN_OBS:-$COMIN} +export COMIN_GES=${COMIN_GES:-$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 +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 NCLEN=${NCLEN:-$HOMEgfs/ush/getncdimlen} +export CATEXEC=${CATEXEC:-$HOMEgsi/exec/nc_diag_cat_serial.x} +export ERRSCRIPT=${ERRSCRIPT:-'eval [[ $err = 0 ]]'} +COMPRESS=${COMPRESS:-gzip} +UNCOMPRESS=${UNCOMPRESS:-gunzip} +APRUNCFP=${APRUNCFP:-""} + +# Diagnostic files options +netcdf_diag=${netcdf_diag:-".true."} +binary_diag=${binary_diag:-".false."} + +# IAU +DOIAU=${DOIAU:-"NO"} +export IAUFHRS=${IAUFHRS:-"6"} + +# Dependent Scripts and Executables +export NTHREADS_CALCINC=${NTHREADS_CALCINC:-1} +export APRUN_CALCINC=${APRUN_CALCINC:-${APRUN:-""}} +export APRUN_CALCANL=${APRUN_CALCANL:-${APRUN:-""}} +export APRUN_CHGRES=${APRUN_CALCANL:-${APRUN:-""}} + +export CALCANLEXEC=${CALCANLEXEC:-$HOMEgsi/exec/calc_analysis.x} +export CHGRESNCEXEC=${CHGRESNCEXEC:-$HOMEgfs/exec/chgres_recenter_ncio.exe} +export CHGRESINCEXEC=${CHGRESINCEXEC:-$HOMEgsi/exec/interp_inc.x} +export NTHREADS_CHGRES=${NTHREADS_CHGRES:-1} +CALCINCPY=${CALCINCPY:-$HOMEgsi/ush/calcinc_gfs.py} +CALCANLPY=${CALCANLPY:-$HOMEgsi/ush/calcanl_gfs.py} + +DOGAUSFCANL=${DOGAUSFCANL-"NO"} +GAUSFCANLSH=${GAUSFCANLSH:-$HOMEgfs/ush/gaussian_sfcanl.sh} +export GAUSFCANLEXE=${GAUSFCANLEXE:-$HOMEgfs/exec/gaussian_sfcanl.exe} +NTHREADS_GAUSFCANL=${NTHREADS_GAUSFCANL:-1} +APRUN_GAUSFCANL=${APRUN_GAUSFCANL:-${APRUN:-""}} + +# OPS flags +RUN=${RUN:-""} +SENDECF=${SENDECF:-"NO"} +SENDDBN=${SENDDBN:-"NO"} + +# Guess files +GPREFIX=${GPREFIX:-""} +GSUFFIX=${GSUFFIX:-$SUFFIX} +ATMG03=${ATMG03:-${COMIN_GES}/${GPREFIX}atmf003${GSUFFIX}} +ATMG04=${ATMG04:-${COMIN_GES}/${GPREFIX}atmf004${GSUFFIX}} +ATMG05=${ATMG05:-${COMIN_GES}/${GPREFIX}atmf005${GSUFFIX}} +ATMGES=${ATMGES:-${COMIN_GES}/${GPREFIX}atmf006${GSUFFIX}} +ATMG07=${ATMG07:-${COMIN_GES}/${GPREFIX}atmf007${GSUFFIX}} +ATMG08=${ATMG08:-${COMIN_GES}/${GPREFIX}atmf008${GSUFFIX}} +ATMG09=${ATMG09:-${COMIN_GES}/${GPREFIX}atmf009${GSUFFIX}} +GBIAS=${GBIAS:-${COMIN_GES}/${GPREFIX}abias} +GBIASPC=${GBIASPC:-${COMIN_GES}/${GPREFIX}abias_pc} +GBIASAIR=${GBIASAIR:-${COMIN_GES}/${GPREFIX}abias_air} + +# Analysis files +export APREFIX=${APREFIX:-""} +export ASUFFIX=${ASUFFIX:-$SUFFIX} +SFCANL=${SFCANL:-${COMOUT}/${APREFIX}sfcanl${ASUFFIX}} +DTFANL=${DTFANL:-${COMOUT}/${APREFIX}dtfanl.nc} +ATMANL=${ATMANL:-${COMOUT}/${APREFIX}atmanl${ASUFFIX}} + +# Increment files +ATMINC=${ATMINC:-${COMOUT}/${APREFIX}atminc.nc} + +# Set script / GSI control parameters +DOHYBVAR=${DOHYBVAR:-"NO"} +lrun_subdirs=${lrun_subdirs:-".true."} +if [ $DOHYBVAR = "YES" ]; then + l_hyb_ens=.true. + export l4densvar=${l4densvar:-".false."} + export lwrite4danl=${lwrite4danl:-".false."} +else + l_hyb_ens=.false. + export l4densvar=.false. + export lwrite4danl=.false. +fi + +# Set 4D-EnVar specific variables +if [ $DOHYBVAR = "YES" -a $l4densvar = ".true." -a $lwrite4danl = ".true." ]; then + ATMA03=${ATMA03:-${COMOUT}/${APREFIX}atma003${ASUFFIX}} + ATMI03=${ATMI03:-${COMOUT}/${APREFIX}atmi003.nc} + ATMA04=${ATMA04:-${COMOUT}/${APREFIX}atma004${ASUFFIX}} + ATMI04=${ATMI04:-${COMOUT}/${APREFIX}atmi004.nc} + ATMA05=${ATMA05:-${COMOUT}/${APREFIX}atma005${ASUFFIX}} + ATMI05=${ATMI05:-${COMOUT}/${APREFIX}atmi005.nc} + ATMA07=${ATMA07:-${COMOUT}/${APREFIX}atma007${ASUFFIX}} + ATMI07=${ATMI07:-${COMOUT}/${APREFIX}atmi007.nc} + ATMA08=${ATMA08:-${COMOUT}/${APREFIX}atma008${ASUFFIX}} + ATMI08=${ATMI08:-${COMOUT}/${APREFIX}atmi008.nc} + ATMA09=${ATMA09:-${COMOUT}/${APREFIX}atma009${ASUFFIX}} + ATMI09=${ATMI09:-${COMOUT}/${APREFIX}atmi009.nc} +fi + +################################################################################ +################################################################################ +# Preprocessing +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi + +cd $DATA || exit 99 + +################################################################################ +# Clean the run-directory +rm -rf dir.* + +############################################################## +# If analysis increment is written by GSI, produce an analysis file here +if [ $DO_CALC_ANALYSIS == "YES" ]; then + # link analysis and increment files + $NLN $ATMANL siganl + $NLN $ATMINC siginc.nc + if [ $DOHYBVAR = "YES" -a $l4densvar = ".true." -a $lwrite4danl = ".true." ]; then + $NLN $ATMA03 siga03 + $NLN $ATMI03 sigi03.nc + $NLN $ATMA04 siga04 + $NLN $ATMI04 sigi04.nc + $NLN $ATMA05 siga05 + $NLN $ATMI05 sigi05.nc + $NLN $ATMA07 siga07 + $NLN $ATMI07 sigi07.nc + $NLN $ATMA08 siga08 + $NLN $ATMI08 sigi08.nc + $NLN $ATMA09 siga09 + $NLN $ATMI09 sigi09.nc + fi + # link guess files + $NLN $ATMG03 sigf03 + $NLN $ATMGES sigf06 + $NLN $ATMG09 sigf09 + + [[ -f $ATMG04 ]] && $NLN $ATMG04 sigf04 + [[ -f $ATMG05 ]] && $NLN $ATMG05 sigf05 + [[ -f $ATMG07 ]] && $NLN $ATMG07 sigf07 + [[ -f $ATMG08 ]] && $NLN $ATMG08 sigf08 + + # Link hourly backgrounds (if present) + if [ -f $ATMG04 -a -f $ATMG05 -a -f $ATMG07 -a -f $ATMG08 ]; then + nhr_obsbin=1 + fi + + $CALCANLPY + rc=$? + + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 3 +else + echo "Neither increment nor analysis are generated by external utils" +fi + +############################################################## +# 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 + + $GAUSFCANLSH + rc=$? + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 12 +fi + +echo "$CDUMP $CDATE atmanl and sfcanl done at `date`" > $COMOUT/${APREFIX}loganl.txt + +################################################################################ +# Send alerts +if [ $SENDDBN = "YES" ]; then + if [ $RUN = "gfs" ]; then + $DBNROOT/bin/dbn_alert MODEL GFS_abias $job $ABIAS + fi +fi + +################################################################################ +# Postprocessing +cd $pwd +[[ $mkdata = "YES" ]] && rm -rf $DATA + +set +x +if [ $VERBOSE = "YES" ]; then + echo $(date) EXITING $0 with return code $err >&2 +fi +exit $err + diff --git a/scripts/exglobal_analdiag_fv3gfs.sh.ecf b/scripts/exglobal_analdiag_fv3gfs.sh.ecf new file mode 100755 index 0000000000..ad07327f25 --- /dev/null +++ b/scripts/exglobal_analdiag_fv3gfs.sh.ecf @@ -0,0 +1,298 @@ +#!/bin/ksh +################################################################################ +#### UNIX Script Documentation Block +# . . +# Script name: exglobal_analdiag_fv3gfs.sh.ecf.sh +# Script description: Creates diagnostic files after GSI analysis is performed +# +# Author: Cory Martin Org: NCEP/EMC Date: 2020-03-03 +# +# Abstract: This script creates GSI diagnostic files after GSI exits successfully +# +# $Id$ +# +# Attributes: +# Language: POSIX shell +# Machine: WCOSS-Dell / Hera +# +################################################################################ + +# Set environment. +export VERBOSE=${VERBOSE:-"YES"} +if [ $VERBOSE = "YES" ]; then + echo $(date) EXECUTING $0 $* >&2 + set -x +fi + +# Directories. +pwd=$(pwd) +export NWPROD=${NWPROD:-$pwd} +export HOMEgfs=${HOMEgfs:-$NWPROD} +export HOMEgsi=${HOMEgsi:-$NWPROD} +export FIXgsm=${FIXgsm:-$HOMEgfs/fix/fix_am} +export DATA=${DATA:-$pwd/analdiag.$$} +export COMIN=${COMIN:-$pwd} +export COMIN_OBS=${COMIN_OBS:-$COMIN} +export COMIN_GES=${COMIN_GES:-$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 +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 NCLEN=${NCLEN:-$HOMEgfs/ush/getncdimlen} +export CATEXEC=${CATEXEC:-$HOMEgsi/exec/nc_diag_cat_serial.x} +export ERRSCRIPT=${ERRSCRIPT:-'eval [[ $err = 0 ]]'} +COMPRESS=${COMPRESS:-gzip} +UNCOMPRESS=${UNCOMPRESS:-gunzip} +APRUNCFP=${APRUNCFP:-""} + +# Diagnostic files options +netcdf_diag=${netcdf_diag:-".true."} +binary_diag=${binary_diag:-".false."} + +# OPS flags +RUN=${RUN:-""} +SENDECF=${SENDECF:-"NO"} +SENDDBN=${SENDDBN:-"NO"} + +# Guess files + +# Analysis files +export APREFIX=${APREFIX:-""} +export ASUFFIX=${ASUFFIX:-$SUFFIX} +RADSTAT=${RADSTAT:-${COMOUT}/${APREFIX}radstat} +PCPSTAT=${PCPSTAT:-${COMOUT}/${APREFIX}pcpstat} +CNVSTAT=${CNVSTAT:-${COMOUT}/${APREFIX}cnvstat} +OZNSTAT=${OZNSTAT:-${COMOUT}/${APREFIX}oznstat} + +# Remove stat file if file already exists +if [ -s $RADSTAT ]; then rm -f $RADSTAT; fi +if [ -s $PCPSTAT ]; then rm -f $PCPSTAT; fi +if [ -s $CNVSTAT ]; then rm -f $CNVSTAT; fi +if [ -s $OZNSTAT ]; then rm -f $OZNSTAT; fi + +# Obs diag +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"} +DIAG_DIR=${COMOUT}/${APREFIX}gsidiags/ + +# Set script / GSI control parameters +lrun_subdirs=${lrun_subdirs:-".true."} + + +################################################################################ +# If requested, generate diagnostic files +if [ $GENDIAG = "YES" ] ; then + if [ $lrun_subdirs = ".true." ] ; then + for pe in $DIAG_DIR/dir.*; do + pedir="$(basename -- $pe)" + $NLN $pe $DATA/$pedir + done + else + echo "lrun_subdirs must be true; exit with error" + $ERRSCRIPT || exit 2 + fi + + # Set up lists and variables for various types of diagnostic files. + ntype=3 + + diagtype[0]="conv conv_gps conv_ps conv_pw conv_q conv_sst conv_t conv_tcp 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 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_n19 avhrr_metop-a amsr2_gcom-w1 gmi_gpm saphir_meghat ahi_himawari8 abi_g16 abi_g17 amsua_metop-c mhs_metop-c iasi_metop-c avhrr_metop-c" + + diaglist[0]=listcnv + diaglist[1]=listpcp + diaglist[2]=listozn + diaglist[3]=listrad + + diagfile[0]=$CNVSTAT + diagfile[1]=$PCPSTAT + diagfile[2]=$OZNSTAT + diagfile[3]=$RADSTAT + + numfile[0]=0 + numfile[1]=0 + numfile[2]=0 + numfile[3]=0 + + # Set diagnostic file prefix based on lrun_subdirs variable + if [ $lrun_subdirs = ".true." ]; then + prefix=" dir.*/" + else + prefix="pe*" + fi + + if [ $USE_CFP = "YES" ]; then + rm $DATA/diag.sh $DATA/mp_diag.sh + cat > $DATA/diag.sh << EOFdiag +#!/bin/sh +lrun_subdirs=\$1 +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} +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 +EOFdiag + chmod 755 $DATA/diag.sh + fi + + # Collect diagnostic files as a function of loop and type. + # 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 + echo $(date) START loop $string >&2 + n=-1 + while [ $((n+=1)) -le $ntype ] ;do + for type in $(echo ${diagtype[n]}); do + count=$(ls ${prefix}${type}_${loop}* | wc -l) + if [ $count -gt 0 ]; then + if [ $USE_CFP = "YES" ]; then + echo "$DATA/diag.sh $lrun_subdirs $binary_diag $type $loop $string $CDATE $DIAG_COMPRESS $DIAG_SUFFIX" | tee -a $DATA/mp_diag.sh + else + 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) + fi + done + done + echo $(date) END loop $string >&2 + done + + # We should already be in $DATA, but extra cd to be sure. + cd $DATA + + # If requested, compress diagnostic files + if [ $DIAG_COMPRESS = "YES" -a $USE_CFP = "NO" ]; then + echo $(date) START $COMPRESS diagnostic files >&2 + for file in $(ls diag_*${CDATE}${DIAG_SUFFIX}); do + $COMPRESS $file + done + echo $(date) END $COMPRESS diagnostic files >&2 + fi + + if [ $USE_CFP = "YES" ] ; then + chmod 755 $DATA/mp_diag.sh + ncmd=$(cat $DATA/mp_diag.sh | wc -l) + if [ $ncmd -gt 0 ]; then + ncmd_max=$((ncmd < npe_node_max ? ncmd : npe_node_max)) + APRUNCFP_DIAG=$(eval echo $APRUNCFP) + if [ ${CFP_MP:-"NO"} = "YES" ]; then + if [ -s $DATA/mp_diag_srun.sh ]; then rm -f $DATA/mp_diag_srun.sh; fi + touch $DATA/mp_diag_srun.sh + nm=0 + cat $DATA/mp_diag.sh | while read line; do + echo "$nm $line" >> $DATA/mp_diag_srun.sh + nm=$((nm+1)) + done + $APRUNCFP_DIAG -n $nm --multi-prog $DATA/mp_diag_srun.sh + else + $APRUNCFP_DIAG $DATA/mp_diag.sh + fi + fi + fi + + # If requested, create diagnostic file tarballs + if [ $DIAG_TARBALL = "YES" ]; then + echo $(date) START tar diagnostic files >&2 + n=-1 + while [ $((n+=1)) -le $ntype ] ;do + TAROPTS="-uvf" + if [ ! -s ${diagfile[n]} ]; then + TAROPTS="-cvf" + fi + if [ ${numfile[n]} -gt 0 ]; then + tar $TAROPTS ${diagfile[n]} $(cat ${diaglist[n]}) + fi + done + + # Restrict CNVSTAT + chmod 750 $CNVSTAT + ${CHGRP_CMD} $CNVSTAT + + # Restrict RADSTAT + chmod 750 $RADSTAT + ${CHGRP_CMD} $RADSTAT + + echo $(date) END tar diagnostic files >&2 + fi +fi # End diagnostic file generation block - if [ $GENDIAG = "YES" ] + +################################################################################ +# Send alerts +if [ $SENDDBN = "YES" ]; then + if [ $RUN = "gdas" ]; then + $DBNROOT/bin/dbn_alert MODEL GDASRADSTAT $job $RADSTAT + fi +fi + +################################################################################ +# Postprocessing +cd $pwd +[[ $mkdata = "YES" ]] && rm -rf $DATA + +set +x +if [ $VERBOSE = "YES" ]; then + echo $(date) EXITING $0 with return code $err >&2 +fi +exit $err + diff --git a/scripts/exglobal_analysis_fv3gfs.sh.ecf b/scripts/exglobal_analysis_fv3gfs.sh.ecf index 97ee8e9151..ac1805febc 100755 --- a/scripts/exglobal_analysis_fv3gfs.sh.ecf +++ b/scripts/exglobal_analysis_fv3gfs.sh.ecf @@ -1,4 +1,4 @@ -#!/bin/sh +#!/bin/ksh ################################################################################ #### UNIX Script Documentation Block # . . @@ -58,6 +58,7 @@ 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 NCLEN=${NCLEN:-$HOMEgfs/ush/getncdimlen} export CATEXEC=${CATEXEC:-$HOMEgsi/exec/nc_diag_cat_serial.x} export ERRSCRIPT=${ERRSCRIPT:-'eval [[ $err = 0 ]]'} COMPRESS=${COMPRESS:-gzip} @@ -90,21 +91,33 @@ export CASE=${CASE:-"C384"} ntiles=${ntiles:-6} # Microphysics in the model; 99:ZC, 11:GFDLMP -imp_physics=${imp_physics:-99} +export imp_physics=${imp_physics:-99} lupp=${lupp:-".true."} +cnvw_option=${cnvw_option:-".false."} # Diagnostic files options lobsdiag_forenkf=${lobsdiag_forenkf:-".false."} -netcdf_diag=${netcdf_diag:-".false."} -binary_diag=${binary_diag:-".true."} +netcdf_diag=${netcdf_diag:-".true."} +binary_diag=${binary_diag:-".false."} # IAU DOIAU=${DOIAU:-"NO"} +export IAUFHRS=${IAUFHRS:-"6"} # Dependent Scripts and Executables -NTHREADS_CALCINC=${NTHREADS_CALCINC:-1} -APRUN_CALCINC=${APRUN_CALCINC:-${APRUN:-""}} -CALCINCEXEC=${CALCINCEXEC:-$HOMEgsi/exec/calc_increment_ens.x} +export NTHREADS_CALCINC=${NTHREADS_CALCINC:-1} +export APRUN_CALCINC=${APRUN_CALCINC:-${APRUN:-""}} +export APRUN_CALCANL=${APRUN_CALCANL:-${APRUN:-""}} +export APRUN_CHGRES=${APRUN_CALCANL:-${APRUN:-""}} +export CALCINCEXEC=${CALCINCEXEC:-$HOMEgsi/exec/calc_increment_ens.x} +export CALCINCNCEXEC=${CALCINCNCEXEC:-$HOMEgsi/exec/calc_increment_ens_ncio.x} +export CALCANLEXEC=${CALCANLEXEC:-$HOMEgsi/exec/calc_analysis.x} +export CHGRESNCEXEC=${CHGRESNCEXEC:-$HOMEgfs/exec/chgres_recenter_ncio.exe} +export CHGRESINCEXEC=${CHGRESINCEXEC:-$HOMEgsi/exec/interp_inc.x} +CHGRESEXEC=${CHGRESEXEC:-$HOMEgfs/exec/chgres_recenter.exe} +export NTHREADS_CHGRES=${NTHREADS_CHGRES:-24} +CALCINCPY=${CALCINCPY:-$HOMEgsi/ush/calcinc_gfs.py} +CALCANLPY=${CALCANLPY:-$HOMEgsi/ush/calcanl_gfs.py} # OPS flags RUN=${RUN:-""} @@ -149,13 +162,14 @@ AMSR2BF=${AMSR2BF:-${COMIN_OBS}/${OPREFIX}amsr2.tm00.bufr_d${OSUFFIX}} GMI1CRBF=${GMI1CRBF:-${COMIN_OBS}/${OPREFIX}gmi1cr.tm00.bufr_d${OSUFFIX}} SAPHIRBF=${SAPHIRBF:-${COMIN_OBS}/${OPREFIX}saphir.tm00.bufr_d${OSUFFIX}} SEVIRIBF=${SEVIRIBF:-${COMIN_OBS}/${OPREFIX}sevcsr.tm00.bufr_d${OSUFFIX}} -AHIBF=${AHIBF:-${COMIN_OBS}/${OPREFIX}ahi.tm00.bufr_d${OSUFFIX}} +AHIBF=${AHIBF:-${COMIN_OBS}/${OPREFIX}ahicsr.tm00.bufr_d${OSUFFIX}} +ABIBF=${ABIBF:-${COMIN_OBS}/${OPREFIX}gsrcsr.tm00.bufr_d${OSUFFIX}} CRISBF=${CRISBF:-${COMIN_OBS}/${OPREFIX}cris.tm00.bufr_d${OSUFFIX}} ESCRIS=${ESCRIS:-${COMIN_OBS}/${OPREFIX}escris.tm00.bufr_d${OSUFFIX}} CRISDB=${CRISDB:-${COMIN_OBS}/${OPREFIX}crisdb.tm00.bufr_d${OSUFFIX}} CRISFSBF=${CRISFSBF:-${COMIN_OBS}/${OPREFIX}crisf4.tm00.bufr_d${OSUFFIX}} -ESCRISFS=${ESCRISFS:-${COMIN_OBS}/${OPREFIX}escrisf4.tm00.bufr_d${OSUFFIX}} -CRISFSDB=${CRISFSDB:-${COMIN_OBS}/${OPREFIX}crisf4db.tm00.bufr_d${OSUFFIX}} +ESCRISFS=${ESCRISFS:-${COMIN_OBS}/${OPREFIX}escrsf.tm00.bufr_d${OSUFFIX}} +CRISFSDB=${CRISFSDB:-${COMIN_OBS}/${OPREFIX}crsfdb.tm00.bufr_d${OSUFFIX}} ATMSBF=${ATMSBF:-${COMIN_OBS}/${OPREFIX}atms.tm00.bufr_d${OSUFFIX}} ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}} ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}} @@ -177,7 +191,7 @@ B1AVHPM=${B1AVHPM:-${COMIN_OBS}/${OPREFIX}avcspm.tm00.bufr_d${OSUFFIX}} # Guess files GPREFIX=${GPREFIX:-""} -GSUFFIX=${GSUFFIX:-""} +GSUFFIX=${GSUFFIX:-$SUFFIX} SFCG03=${SFCG03:-${COMIN_GES}/${GPREFIX}sfcf003${GSUFFIX}} SFCG04=${SFCG04:-${COMIN_GES}/${GPREFIX}sfcf004${GSUFFIX}} SFCG05=${SFCG05:-${COMIN_GES}/${GPREFIX}sfcf005${GSUFFIX}} @@ -198,8 +212,8 @@ GBIASAIR=${GBIASAIR:-${COMIN_GES}/${GPREFIX}abias_air} GRADSTAT=${GRADSTAT:-${COMIN_GES}/${GPREFIX}radstat} # Analysis files -APREFIX=${APREFIX:-""} -ASUFFIX=${ASUFFIX:-""} +export APREFIX=${APREFIX:-""} +export ASUFFIX=${ASUFFIX:-$SUFFIX} SFCANL=${SFCANL:-${COMOUT}/${APREFIX}sfcanl${ASUFFIX}} DTFANL=${DTFANL:-${COMOUT}/${APREFIX}dtfanl.nc} ATMANL=${ATMANL:-${COMOUT}/${APREFIX}atmanl${ASUFFIX}} @@ -213,6 +227,9 @@ PCPSTAT=${PCPSTAT:-${COMOUT}/${APREFIX}pcpstat} CNVSTAT=${CNVSTAT:-${COMOUT}/${APREFIX}cnvstat} OZNSTAT=${OZNSTAT:-${COMOUT}/${APREFIX}oznstat} +# Increment files +ATMINC=${ATMINC:-${COMOUT}/${APREFIX}atminc.nc} + # Obs diag RUN_SELECT=${RUN_SELECT:-"NO"} USE_SELECT=${USE_SELECT:-"NO"} @@ -226,6 +243,7 @@ fi DIAG_COMPRESS=${DIAG_COMPRESS:-"YES"} DIAG_TARBALL=${DIAG_TARBALL:-"YES"} USE_CFP=${USE_CFP:-"NO"} +DIAG_DIR=${COMOUT}/${APREFIX}gsidiags # Set script / GSI control parameters DOHYBVAR=${DOHYBVAR:-"NO"} @@ -240,30 +258,48 @@ FAC_TSL=${FAC_TSL:-1} TZR_QC=${TZR_QC:-1} USE_READIN_ANL_SFCMASK=${USE_READIN_ANL_SFCMASK:-.false.} SMOOTH_ENKF=${SMOOTH_ENKF:-"YES"} -DOIAU=${DOIAU:-"NO"} -DO_CALC_INCREMENT=${DO_CALC_INCREMENT:-"YES"} -INCREMENTS_TO_ZERO=${INCREMENTS_TO_ZERO:-"'NONE'"} +export DOIAU=${DOIAU:-"NO"} +DO_CALC_INCREMENT=${DO_CALC_INCREMENT:-"NO"} +DO_CALC_ANALYSIS=${DO_CALC_ANALYSIS:-"NO"} +export 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}')} # '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 +if [ ${SUFFIX} = ".nc" ]; then + LONB=${LONB:-$($NCLEN $ATMGES grid_xt)} # get LONB + LATB=${LATB:-$($NCLEN $ATMGES grid_yt)} # get LATB + LEVS=${LEVS:-$($NCLEN $ATMGES pfull)} # get LEVS + JCAP=${JCAP:--9999} # there is no jcap in these files +else + 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 +fi [ $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}')} # '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 + export ATMGES_ENSMEAN=${ATMGES_ENSMEAN:-${COMIN_GES_ENS}/${GPREFIX}atmf006.ensmean${GSUFFIX}} + if [ ${SUFFIX} = ".nc" ]; then + LONB_ENKF=${LONB_ENKF:-$($NCLEN $ATMGES_ENSMEAN grid_xt)} # get LONB_ENKF + LATB_ENKF=${LATB_ENKF:-$($NCLEN $ATMGES_ENSMEAN grid_yt)} # get LATB_ENFK + LEVS_ENKF=${LEVS_ENKF:-$($NCLEN $ATMGES_ENSMEAN pfull)} # get LATB_ENFK + JCAP_ENKF=${JCAP_ENKF:--9999} # again, no jcap in the netcdf files + else + 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 + LEVS_ENKF=${LEVS_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimz | grep -i "dimz" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get LEVS_ENKF + JCAP_ENKF=${JCAP_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN jcap | grep -i "jcap" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get JCAP_ENKF + fi NLON_ENKF=${NLON_ENKF:-$LONB_ENKF} NLAT_ENKF=${NLAT_ENKF:-$(($LATB_ENKF+2))} - 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 +else + LONB_ENKF=0 # just for if statement later fi # Get dimension information based on CASE @@ -287,6 +323,27 @@ NLAT_A=${NLAT_A:-$(($LATA+2))} DELTIM=${DELTIM:-$((3600/($JCAP_A/20)))} +# logic for netCDF I/O +if [ ${SUFFIX} = ".nc" ]; then + # GSI namelist options to use netCDF background + use_gfs_nemsio=".false." + use_gfs_ncio=".true." +else + # GSI namelist options to use NEMSIO background + use_gfs_nemsio=".true." + use_gfs_ncio=".false." +fi + +# determine if writing or calculating increment +if [ $DO_CALC_INCREMENT = "YES" ]; then + write_fv3_increment=".false." +else + write_fv3_increment=".true." + WRITE_INCR_ZERO="incvars_to_zero= $INCREMENTS_TO_ZERO," + WRITE_ZERO_STRAT="incvars_zero_strat= $INCVARS_ZERO_STRAT," + WRITE_STRAT_EFOLD="incvars_efold= $INCVARS_EFOLD," +fi + # GSI Fix files RTMFIX=${RTMFIX:-${CRTM_FIX}} BERROR=${BERROR:-${FIXgsi}/Big_Endian/global_berror.l${LEVS}y${NLAT_A}.f77} @@ -296,6 +353,7 @@ RADCLOUDINFO=${RADCLOUDINFO:-${FIXgsi}/cloudy_radiance_info.txt} ATMSFILTER=${ATMSFILTER:-${FIXgsi}/atms_beamwidth.txt} ANAVINFO=${ANAVINFO:-${FIXgsi}/global_anavinfo.l${LEVS}.txt} CONVINFO=${CONVINFO:-${FIXgsi}/global_convinfo.txt} +vqcdat=${vqcdat:-${FIXgsi}/vqctp001.dat} INSITUINFO=${INSITUINFO:-${FIXgsi}/global_insituinfo.txt} OZINFO=${OZINFO:-${FIXgsi}/global_ozinfo.txt} PCPINFO=${PCPINFO:-${FIXgsi}/global_pcpinfo.txt} @@ -325,22 +383,28 @@ NST=${NST:-""} lrun_subdirs=${lrun_subdirs:-".true."} if [ $DOHYBVAR = "YES" ]; then l_hyb_ens=.true. - l4densvar=${l4densvar:-".false."} - lwrite4danl=${lwrite4danl:-".false."} + export l4densvar=${l4densvar:-".false."} + export lwrite4danl=${lwrite4danl:-".false."} else l_hyb_ens=.false. - l4densvar=.false. - lwrite4danl=.false. + export l4densvar=.false. + export lwrite4danl=.false. fi # Set 4D-EnVar specific variables if [ $DOHYBVAR = "YES" -a $l4densvar = ".true." -a $lwrite4danl = ".true." ]; then ATMA03=${ATMA03:-${COMOUT}/${APREFIX}atma003${ASUFFIX}} + ATMI03=${ATMI03:-${COMOUT}/${APREFIX}atmi003.nc} ATMA04=${ATMA04:-${COMOUT}/${APREFIX}atma004${ASUFFIX}} + ATMI04=${ATMI04:-${COMOUT}/${APREFIX}atmi004.nc} ATMA05=${ATMA05:-${COMOUT}/${APREFIX}atma005${ASUFFIX}} + ATMI05=${ATMI05:-${COMOUT}/${APREFIX}atmi005.nc} ATMA07=${ATMA07:-${COMOUT}/${APREFIX}atma007${ASUFFIX}} + ATMI07=${ATMI07:-${COMOUT}/${APREFIX}atmi007.nc} ATMA08=${ATMA08:-${COMOUT}/${APREFIX}atma008${ASUFFIX}} + ATMI08=${ATMI08:-${COMOUT}/${APREFIX}atmi008.nc} ATMA09=${ATMA09:-${COMOUT}/${APREFIX}atma009${ASUFFIX}} + ATMI09=${ATMI09:-${COMOUT}/${APREFIX}atmi009.nc} fi ################################################################################ @@ -357,7 +421,7 @@ cd $DATA || exit 99 # Clean the run-directory rm berror_stats hybens_info rm scaninfo satbias_angle satinfo -rm anavinfo convinfo ozinfo pcpinfo aeroinfo +rm anavinfo convinfo ozinfo pcpinfo aeroinfo vqctp001.dat rm errtable atms_beamwidth.txt rm cloudy_radiance_info.txt @@ -375,7 +439,7 @@ rm hirs2bufr hirs3bufr hirs4bufr hirs3bufr_db hirs3bufrears rm amsuabufr amsuabufr_db amsuabufrears rm amsubbufr amsubbufr_db amsubbufrears rm mhsbufr mhsbufr_db mhsbufrears -rm seviribufr ahibufr +rm seviribufr ahibufr abibufr rm crisbufr crisbufrears crisbufr_db crisfsbufr crisfsbufrears crisfsbufr_db rm atmsbufr atmsbufr_db atmsbufrears @@ -384,6 +448,7 @@ rm aircftbias_in aircftbias_out rm sfcf* sigf* nstf* rm sfca* siga* nsta* +rm sigi* rm gsiparm.anl @@ -400,6 +465,7 @@ $NLN $RADCLOUDINFO cloudy_radiance_info.txt $NLN $ATMSFILTER atms_beamwidth.txt $NLN $ANAVINFO anavinfo $NLN $CONVINFO convinfo +$NLN $vqcdat vqctp001.dat $NLN $INSITUINFO insituinfo $NLN $OZINFO ozinfo $NLN $PCPINFO pcpinfo @@ -409,18 +475,28 @@ $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 +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 + echo "using correlated obs error" + else + echo "Error: Satellite error covariance files are missing." + echo "Check for the required Rcov files in " $ANAVINFO + exit 1 + fi + else + echo "Error: Satellite error covariance info missing in " $ANAVINFO + exit 1 fi + +# Correlated error utlizes mkl lapack. Found it necesary to fix the +# number of mkl threads to ensure reproducible results independent +# of the job configuration. + export MKL_NUM_THREADS=1 + +else + echo "not using correlated obs error" fi ############################################################## @@ -488,8 +564,8 @@ $NLN $CRISBF crisbufr $NLN $ESCRIS crisbufrears $NLN $CRISDB crisbufr_db $NLN $CRISFSBF crisfsbufr -#$NLN $ESCRISFS crisfsbufrears -#$NLN $CRISFSDB crisfsbufr_db +$NLN $ESCRISFS crisfsbufrears +$NLN $CRISFSDB crisfsbufr_db $NLN $ATMSBF atmsbufr $NLN $ESATMS atmsbufrears $NLN $ATMSDB atmsbufr_db @@ -500,6 +576,7 @@ $NLN $TCVITL tcvitl $NLN $B1AVHAM avhambufr $NLN $B1AVHPM avhpmbufr $NLN $AHIBF ahibufr +$NLN $ABIBF abibufr [[ $DONST = "YES" ]] && $NLN $NSSTBF nsstbufr @@ -552,6 +629,9 @@ if [ $DOHYBVAR = "YES" ]; then memchar="mem"$(printf %03i $imem) for fhr in $fhrs; do $NLN ${COMIN_GES_ENS}/$memchar/${GPREFIX}atmf0${fhr}${ENKF_SUFFIX}${GSUFFIX} ./ensemble_data/sigf${fhr}_ens_$memchar + if [ $cnvw_option = ".true." ]; then + $NLN ${COMIN_GES_ENS}/$memchar/${GPREFIX}sfcf0${fhr}${GSUFFIX} ./ensemble_data/sfcf${fhr}_ens_$memchar + fi done done @@ -573,17 +653,44 @@ if [ $JCAP -ne $JCAP_A ]; then fi fi +############################################################## +# Diagnostic files +# if requested, link GSI diagnostic file directories for use later +if [ $GENDIAG = "YES" ] ; then + if [ $lrun_subdirs = ".true." ] ; then + if [ -d $DIAG_DIR ]; then + rm -rf $DIAG_DIR + fi + npe_m1="$(($npe_gsi-1))" + for pe in {0..$npe_m1}; do + pedir="dir."$(printf %04i $pe) + mkdir -p $DIAG_DIR/$pedir + $NLN $DIAG_DIR/$pedir $pedir + done + else + echo "lrun_subdirs must be true; exit with error" + $ERRSCRIPT || exit 2 + fi +fi + ############################################################## # Output files # $SFCANL is no longer created here since global_cycle is not called $NLN $ATMANL siganl +$NLN $ATMINC siginc.nc if [ $DOHYBVAR = "YES" -a $l4densvar = ".true." -a $lwrite4danl = ".true." ]; then $NLN $ATMA03 siga03 + $NLN $ATMI03 sigi03.nc $NLN $ATMA04 siga04 + $NLN $ATMI04 sigi04.nc $NLN $ATMA05 siga05 + $NLN $ATMI05 sigi05.nc $NLN $ATMA07 siga07 + $NLN $ATMI07 sigi07.nc $NLN $ATMA08 siga08 + $NLN $ATMI08 sigi08.nc $NLN $ATMA09 siga09 + $NLN $ATMI09 sigi09.nc fi $NLN $ABIAS satbias_out $NLN $ABIASPC satbias_pc.out @@ -684,15 +791,20 @@ cat > gsiparm.anl << EOF tzr_qc=$TZR_QC, 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_gfs_nemsio=${use_gfs_nemsio},use_gfs_ncio=${use_gfs_ncio},sfcnst_comb=.true., use_readin_anl_sfcmask=${USE_READIN_ANL_SFCMASK}, lrun_subdirs=$lrun_subdirs, 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=${nhr_obsbin:-3}, - cwoption=3,imp_physics=$imp_physics,lupp=$lupp, + cwoption=3,imp_physics=$imp_physics,lupp=$lupp,cnvw_option=$cnvw_option, netcdf_diag=$netcdf_diag,binary_diag=$binary_diag, lobsdiag_forenkf=$lobsdiag_forenkf, + write_fv3_incr=$write_fv3_increment, + nhr_anal=${IAUFHRS}, + $WRITE_INCR_ZERO + $WRITE_ZERO_STRAT + $WRITE_STRAT_EFOLD $SETUP / &GRIDOPTS @@ -724,8 +836,9 @@ 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.,cleanup_tail=.true., + use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,nvqc=.true., + aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true., + tcp_width=70.0,tcp_ermax=7.35, $OBSQC / &OBS_INPUT @@ -818,15 +931,20 @@ OBS_INPUT:: 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 + avhambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 + avhpmbufr avhrr n19 avhrr3_n19 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 + ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 + abibufr abi g16 abi_g16 0.0 1 0 + abibufr abi g17 abi_g17 0.0 1 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 + iasibufr iasi metop-c iasi_metop-c 0.0 1 1 :: &SUPEROB_RADAR $SUPERRAD @@ -874,45 +992,12 @@ export ERR=$? export err=$ERR $ERRSCRIPT || exit 2 + ############################################################## -# Calculate analysis increment here before releasing FV3 forecast +# If full analysis field written, calculate analysis increment +# here before releasing FV3 forecast if [ $DO_CALC_INCREMENT = "YES" ]; then - if [ $DOIAU = "YES" -a $l4densvar = ".true." -a $lwrite4danl = ".true." ]; then - ncmd=7 - $NLN sigf03 atmges_mem001 ; $NLN siga03 atmanl_mem001 ; $NLN ${COMOUT}/${APREFIX}atmi003.nc atminc_mem001 - $NLN sigf04 atmges_mem002 ; $NLN siga04 atmanl_mem002 ; $NLN ${COMOUT}/${APREFIX}atmi004.nc atminc_mem002 - $NLN sigf05 atmges_mem003 ; $NLN siga05 atmanl_mem003 ; $NLN ${COMOUT}/${APREFIX}atmi005.nc atminc_mem003 - $NLN sigf06 atmges_mem004 ; $NLN siganl atmanl_mem004 ; $NLN ${COMOUT}/${APREFIX}atminc.nc atminc_mem004 - $NLN sigf07 atmges_mem005 ; $NLN siga07 atmanl_mem005 ; $NLN ${COMOUT}/${APREFIX}atmi007.nc atminc_mem005 - $NLN sigf08 atmges_mem006 ; $NLN siga08 atmanl_mem006 ; $NLN ${COMOUT}/${APREFIX}atmi008.nc atminc_mem006 - $NLN sigf09 atmges_mem007 ; $NLN siga09 atmanl_mem007 ; $NLN ${COMOUT}/${APREFIX}atmi009.nc atminc_mem007 - else - ncmd=1 - $NLN sigf06 atmges_mem001 ; $NLN siganl atmanl_mem001 ; $NLN ${COMOUT}/${APREFIX}atminc.nc atminc_mem001 - fi - - export OMP_NUM_THREADS=$NTHREADS_CALCINC - $NCP $CALCINCEXEC $DATA - - rm calc_increment.nml - cat > calc_increment.nml << EOF -&setup - datapath = './' - analysis_filename = 'atmanl' - firstguess_filename = 'atmges' - increment_filename = 'atminc' - debug = .false. - nens = $ncmd - imp_physics = $imp_physics -/ -&zeroinc - incvars_to_zero = $INCREMENTS_TO_ZERO -/ -EOF - cat calc_increment.nml - - APRUN=$(eval echo $APRUN_CALCINC) - $APRUN $DATA/$(basename $CALCINCEXEC) + $CALCINCPY rc=$? export ERR=$rc @@ -920,6 +1005,7 @@ EOF $ERRSCRIPT || exit 3 fi +############################################################## # Update surface fields in the FV3 restart's using global_cycle if [ $DOGCYCLE = "YES" ]; then @@ -995,20 +1081,9 @@ if [ $DOGCYCLE = "YES" ]; then export err=$ERR $ERRSCRIPT || exit 11 - # 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 - - $GAUSFCANLSH - rc=$? - export ERR=$rc - export err=$ERR - $ERRSCRIPT || exit 12 - fi - fi + ############################################################## # For eupd if [ -s satbias_out.int ]; then @@ -1017,17 +1092,6 @@ else $NCP satbias_in $ABIASe fi -############################################################## -# Add this statement to release the forecast job once the GSI -# step is completed. Do not release forecast when RUN=enkf -############################################################## -if [ $SENDECF = "YES" -a "$RUN" != "enkf" ]; then - ecflow_client --event release_fcst -fi - -# We should already be in $DATA, but extra cd to be sure. -cd $DATA - # Cat runtime output files. cat fort.2* > $GSISTAT @@ -1043,178 +1107,26 @@ if [ $RUN_SELECT = "YES" ]; then echo $(date) END tar obs_input >&2 fi -# If requested, generate diagnostic files -if [ $GENDIAG = "YES" ] ; then - - # Set up lists and variables for various types of diagnostic files. - ntype=3 - - 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 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 - diaglist[2]=listozn - diaglist[3]=listrad - - diagfile[0]=$CNVSTAT - diagfile[1]=$PCPSTAT - diagfile[2]=$OZNSTAT - diagfile[3]=$RADSTAT - - numfile[0]=0 - numfile[1]=0 - numfile[2]=0 - numfile[3]=0 - - # Set diagnostic file prefix based on lrun_subdirs variable - if [ $lrun_subdirs = ".true." ]; then - prefix=" dir.*/" - else - prefix="pe*" - fi - - if [ $USE_CFP = "YES" ]; then - rm $DATA/diag.sh $DATA/mp_diag.sh - cat > $DATA/diag.sh << EOFdiag -#!/bin/sh -lrun_subdirs=\$1 -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} -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 -EOFdiag - chmod 755 $DATA/diag.sh - fi - - # Collect diagnostic files as a function of loop and type. - # 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 - echo $(date) START loop $string >&2 - n=-1 - while [ $((n+=1)) -le $ntype ] ;do - for type in $(echo ${diagtype[n]}); do - count=$(ls ${prefix}${type}_${loop}* | wc -l) - if [ $count -gt 0 ]; then - if [ $USE_CFP = "YES" ]; then - echo "$DATA/diag.sh $lrun_subdirs $binary_diag $type $loop $string $CDATE $DIAG_COMPRESS $DIAG_SUFFIX" | tee -a $DATA/mp_diag.sh - else - 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) - fi - done - done - echo $(date) END loop $string >&2 - done - - # We should already be in $DATA, but extra cd to be sure. - cd $DATA - - # If requested, compress diagnostic files - if [ $DIAG_COMPRESS = "YES" -a $USE_CFP = "NO" ]; then - echo $(date) START $COMPRESS diagnostic files >&2 - for file in $(ls diag_*${CDATE}${DIAG_SUFFIX}); do - $COMPRESS $file - done - echo $(date) END $COMPRESS diagnostic files >&2 - fi - - if [ $USE_CFP = "YES" ] ; then - chmod 755 $DATA/mp_diag.sh - ncmd=$(cat $DATA/mp_diag.sh | wc -l) - if [ $ncmd -gt 0 ]; then - ncmd_max=$((ncmd < npe_node_max ? ncmd : npe_node_max)) - APRUNCFP_DIAG=$(eval echo $APRUNCFP) - $APRUNCFP_DIAG $DATA/mp_diag.sh - fi - fi - - # If requested, create diagnostic file tarballs - if [ $DIAG_TARBALL = "YES" ]; then - echo $(date) START tar diagnostic files >&2 - n=-1 - while [ $((n+=1)) -le $ntype ] ;do - TAROPTS="-uvf" - if [ ! -s ${diagfile[n]} ]; then - TAROPTS="-cvf" - fi - if [ ${numfile[n]} -gt 0 ]; then - tar $TAROPTS ${diagfile[n]} $(cat ${diaglist[n]}) - fi - done - - # Restrict CNVSTAT - chmod 750 $CNVSTAT - ${CHGRP_CMD} $CNVSTAT - - # Restrict RADSTAT - chmod 750 $RADSTAT - ${CHGRP_CMD} $RADSTAT - - echo $(date) END tar diagnostic files >&2 - fi - -fi # End diagnostic file generation block - if [ $GENDIAG = "YES" ] - - -################################################################################ -# Send alerts -if [ $SENDDBN = "YES" ]; then - if [ $RUN = "gdas" ]; then - $DBNROOT/bin/dbn_alert MODEL GDASRADSTAT $job $RADSTAT - fi - if [ $RUN = "gfs" ]; then - $DBNROOT/bin/dbn_alert MODEL GFS_abias $job $ABIAS - fi -fi - ################################################################################ # Postprocessing cd $pwd [[ $mkdata = "YES" ]] && rm -rf $DATA +############################################################## +# Add this statement to release the forecast job once the +# atmopsheric analysis and updated surface RESTARTS are +# available. Do not release forecast when RUN=enkf +############################################################## +if [ $SENDECF = "YES" -a "$RUN" != "enkf" ]; then + ecflow_client --event release_fcst +fi +echo "$CDUMP $CDATE atminc and tiled sfcanl done at `date`" > $COMOUT/${APREFIX}loginc.txt + +################################################################################ set +x if [ $VERBOSE = "YES" ]; then echo $(date) EXITING $0 with return code $err >&2 fi exit $err + +################################################################################ diff --git a/scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf b/scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf index 7ed6cbdb67..11b7a0a5b0 100755 --- a/scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf @@ -35,6 +35,8 @@ export DATA=${DATA:-$pwd/enkf_fcst.$$} export COMIN=${COMIN:-$pwd} export COMOUT=${COMOUT:-$COMIN} +GSUFFIX=${GSUFFIX:-$SUFFIX} + # Utilities export NCP=${NCP:-"/bin/cp -p"} export NMV=${NMV:-"/bin/mv"} @@ -65,6 +67,10 @@ export CDUMP=${CDUMP:-"gdas"} # Re-run failed members, or entire group RERUN_EFCSGRP=${RERUN_EFCSGRP:-"YES"} +# Recenter flag and increment file prefix +RECENTER_ENKF=${RECENTER_ENKF:-"YES"} +export PREFIX_ATMINC=${PREFIX_ATMINC:-""} + # Ops related stuff SENDECF=${SENDECF:-"NO"} SENDDBN=${SENDDBN:-"NO"} @@ -134,6 +140,11 @@ export shal_cnv=${shal_cnv_ENKF:-${shal_cnv:-".true."}} export FHZER=${FHZER_ENKF:-${FHZER:-6}} export FHCYC=${FHCYC_ENKF:-${FHCYC:-6}} +# Set PREFIX_ATMINC to r when recentering on +if [ $RECENTER_ENKF = "YES" ]; then + export PREFIX_ATMINC="r" +fi + # APRUN for different executables export APRUN_FV3=${APRUN_FV3:-${APRUN:-""}} export NTHREADS_FV3=${NTHREADS_FV3:-${NTHREADS:-1}} @@ -168,11 +179,12 @@ for imem in $(seq $ENSBEG $ENSEND); do $FORECASTSH ra=$? - # Notify a member forecast failed, freeze epos, but continue on to next member + # Notify a member forecast failed and abort if [ $ra -ne 0 ]; then - msg="forecast of member $cmem FAILED" + msg="FATAL ERROR: forecast of member $cmem FAILED. Aborting job" print $msg - [[ $SENDECF = "YES" ]] && ecflow_client --abort=$msg + export err=$ra + $ERRSCRIPT || exit 2 fi ((rc+=ra)) @@ -184,7 +196,7 @@ for imem in $(seq $ENSBEG $ENSEND); do 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 + $DBNROOT/bin/dbn_alert MODEL GFS_ENKF $job $COMOUT/$memchar/${CDUMP}.t${cyc}z.sfcf${FH3}.${GSUFFIX} fi fhr=$((fhr+FHOUT)) done diff --git a/scripts/exglobal_enkf_post_fv3gfs.sh.ecf b/scripts/exglobal_enkf_post_fv3gfs.sh.ecf index 62c45149c6..b46f46ff82 100755 --- a/scripts/exglobal_enkf_post_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_post_fv3gfs.sh.ecf @@ -51,7 +51,6 @@ HYBENSMOOTH=${HYBENSMOOTH:-$FIXgsi/global_hybens_smoothinfo.l${LEVS}.txt} # Executables. GETATMENSMEANEXEC=${GETATMENSMEANEXEC:-$HOMEgsi/exec/getsigensmeanp_smooth.x} GETSFCENSMEANEXEC=${GETSFCENSMEANEXEC:-$HOMEgsi/exec/getsfcensmeanp.x} -GETATMENSSTATEXEC=${GETATMENSSTATEXEC:-$HOMEgsi/exec/getsigensstatp.x} # Other variables. PREFIX=${PREFIX:-""} @@ -60,7 +59,8 @@ FHMIN=${FHMIN_EPOS:-3} FHMAX=${FHMAX_EPOS:-9} FHOUT=${FHOUT_EPOS:-3} NMEM_ENKF=${NMEM_ENKF:-80} -SMOOTH_ENKF=${SMOOTH_ENKF:-"YES"} +SMOOTH_ENKF=${SMOOTH_ENKF:-"NO"} +ENKF_SPREAD=${ENKF_SPREAD:-"NO"} ################################################################################ # Preprocessing @@ -78,7 +78,6 @@ ENKF_SUFFIX="s" # Copy executables to working directory $NCP $GETSFCENSMEANEXEC $DATA $NCP $GETATMENSMEANEXEC $DATA -$NCP $GETATMENSSTATEXEC $DATA export OMP_NUM_THREADS=$NTHREADS_EPOS @@ -104,8 +103,7 @@ for fhr in $(seq $FHMIN $FHOUT $FHMAX); do $NLN $COMOUT/$memchar/${PREFIX}atmf${fhrchar}${ENKF_SUFFIX}${SUFFIX} atmf${fhrchar}${ENKF_SUFFIX}_$memchar done fi - $NLN $COMOUT/${PREFIX}atmf${fhrchar}.ensmean.nc4 atmf${fhrchar}_ensmean.nc4 - $NLN $COMOUT/${PREFIX}atmf${fhrchar}.ensspread.nc4 atmf${fhrchar}_ensspread.nc4 + [[ $ENKF_SPREAD = "YES" ]] && $NLN $COMOUT/${PREFIX}atmf${fhrchar}.ensspread${SUFFIX} atmf${fhrchar}.ensspread done ################################################################################ @@ -120,10 +118,11 @@ for fhr in $(seq $FHMIN $FHOUT $FHMAX); do $APRUN_EPOS ${DATA}/$(basename $GETSFCENSMEANEXEC) ./ sfcf${fhrchar}.ensmean sfcf${fhrchar} $NMEM_ENKF ra=$? ((rc+=ra)) - $APRUN_EPOS ${DATA}/$(basename $GETATMENSMEANEXEC) ./ atmf${fhrchar}.ensmean atmf${fhrchar} $NMEM_ENKF - ra=$? - ((rc+=ra)) - $APRUN_EPOS ${DATA}/$(basename $GETATMENSSTATEXEC) ./ atmf${fhrchar} $NMEM_ENKF + if [ $ENKF_SPREAD = "YES" ]; then + $APRUN_EPOS ${DATA}/$(basename $GETATMENSMEANEXEC) ./ atmf${fhrchar}.ensmean atmf${fhrchar} $NMEM_ENKF atmf${fhrchar}.ensspread + else + $APRUN_EPOS ${DATA}/$(basename $GETATMENSMEANEXEC) ./ atmf${fhrchar}.ensmean atmf${fhrchar} $NMEM_ENKF + fi ra=$? ((rc+=ra)) done diff --git a/scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf b/scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf index bbf5279a52..707fcc3141 100755 --- a/scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf @@ -50,6 +50,7 @@ ERRSCRIPT=${ERRSCRIPT:-'eval [[ $err = 0 ]]'} NCP=${NCP:-"/bin/cp -p"} NLN=${NLN:-"/bin/ln -sf"} NEMSIOGET=${NEMSIOGET:-${NWPROD}/exec/nemsio_get} +NCLEN=${NCLEN:-$HOMEgfs/ush/getncdimlen} # Scripts @@ -57,26 +58,33 @@ NEMSIOGET=${NEMSIOGET:-${NWPROD}/exec/nemsio_get} GETATMENSMEANEXEC=${GETATMENSMEANEXEC:-$HOMEgsi/exec/getsigensmeanp_smooth.x} GETSFCENSMEANEXEC=${GETSFCENSMEANEXEC:-$HOMEgsi/exec/getsfcensmeanp.x} RECENATMEXEC=${RECENATMEXEC:-$HOMEgsi/exec/recentersigp.x} -CALCINCEXEC=${CALCINCEXEC:-$HOMEgsi/exec/calc_increment_ens.x} +CALCINCNEMSEXEC=${CALCINCNEMSEXEC:-$HOMEgsi/exec/calc_increment_ens.x} +CALCINCNCEXEC=${CALCINCEXEC:-$HOMEgsi/exec/calc_increment_ens_ncio.x} # Files. OPREFIX=${OPREFIX:-""} OSUFFIX=${OSUFFIX:-""} APREFIX=${APREFIX:-""} APREFIX_ENKF=${APREFIX_ENKF:-$APREFIX} -ASUFFIX=${ASUFFIX:-""} +ASUFFIX=${ASUFFIX:-$SUFFIX} GPREFIX=${GPREFIX:-""} -GSUFFIX=${GSUFFIX:-""} +GSUFFIX=${GSUFFIX:-$SUFFIX} # Variables 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} +FHMIN=${FHMIN_ECEN:-3} +FHMAX=${FHMAX_ECEN:-9} +FHOUT=${FHOUT_ECEN:-3} +FHSFC=${FHSFC_ECEN:-$FHMIN} +DO_CALC_INCREMENT=${DO_CALC_INCREMENT:-"NO"} + # global_chgres stuff -CHGRESEXEC=${CHGRESEXEC:-$HOMEgfs/exec/chgres_recenter.exe} +CHGRESNEMS=${CHGRESNEMS:-$HOMEgfs/exec/chgres_recenter.exe} +CHGRESNC=${CHGRESNC:-$HOMEgfs/exec/chgres_recenter_ncio.exe} NTHREADS_CHGRES=${NTHREADS_CHGRES:-24} APRUN_CHGRES=${APRUN_CHGRES:-""} @@ -91,6 +99,7 @@ export CYCLVARS=${CYCLVARS:-"FSNOL=-2.,FSNOS=99999.,"} export FHOUR=${FHOUR:-0} export DELTSFC=${DELTSFC:-6} + RECENTER_ENKF=${RECENTER_ENKF:-"YES"} SMOOTH_ENKF=${SMOOTH_ENKF:-"YES"} @@ -113,16 +122,17 @@ 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 FHR in $(seq $FHMIN $FHOUT $FHMAX); do for imem in $(seq 1 $NMEM_ENKF); do memchar="mem"$(printf %03i $imem) $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 + if [ $DO_CALC_INCREMENT = "YES" ]; then + if [ $FHR -eq 6 ]; then + $NLN $COMIN_ENS/$memchar/${APREFIX_ENKF}atmanl$ASUFFIX ./atmanl_$memchar + else + $NLN $COMIN_ENS/$memchar/${APREFIX_ENKF}atma00${FHR}$ASUFFIX ./atmanl_$memchar + fi fi mkdir -p $COMOUT_ENS/$memchar if [ $FHR -eq 6 ]; then @@ -131,40 +141,104 @@ for imem in $(seq 1 $NMEM_ENKF); do $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 + if [ $DO_CALC_INCREMENT = "YES" ]; then + if [ $FHR -eq 6 ]; then + $NLN $COMOUT_ENS/$memchar/${APREFIX}ratmanl$ASUFFIX ./ratmanl_$memchar + else + $NLN $COMOUT_ENS/$memchar/${APREFIX}ratma00${FHR}$ASUFFIX ./ratmanl_$memchar + fi + else + if [ $FHR -eq 6 ]; then + $NLN $COMOUT_ENS/$memchar/${APREFIX}ratminc$ASUFFIX ./ratminc_$memchar + else + $NLN $COMOUT_ENS/$memchar/${APREFIX}ratmi00${FHR}$ASUFFIX ./ratminc_$memchar + fi + fi fi done -# Link ensemble mean analysis -if [ $FHR -eq 6 ]; then - $NLN $COMIN_ENS/${APREFIX_ENKF}atmanl.ensmean$ASUFFIX ./atmanl_ensmean +if [ $DO_CALC_INCREMENT = "YES" ]; then + # Link ensemble mean analysis + if [ $FHR -eq 6 ]; then + $NLN $COMIN_ENS/${APREFIX_ENKF}atmanl.ensmean$ASUFFIX ./atmanl_ensmean + else + $NLN $COMIN_ENS/${APREFIX_ENKF}atma00${FHR}.ensmean$ASUFFIX ./atmanl_ensmean + fi + + # Compute ensemble mean analysis + DATAPATH="./" + ATMANLNAME="atmanl" + ATMANLMEANNAME="atmanl_ensmean" + + export OMP_NUM_THREADS=$NTHREADS_ECEN + + $NCP $GETATMENSMEANEXEC $DATA + $APRUN_ECEN ${DATA}/$(basename $GETATMENSMEANEXEC) $DATAPATH $ATMANLMEANNAME $ATMANLNAME $NMEM_ENKF + rc=$? + + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 2 else - $NLN $COMIN_ENS/${APREFIX_ENKF}atmanl00${FHR}.ensmean$ASUFFIX ./atmanl_ensmean -fi + # Link ensemble mean increment + if [ $FHR -eq 6 ]; then + $NLN $COMIN_ENS/${APREFIX_ENKF}atminc.ensmean$ASUFFIX ./atminc_ensmean + else + $NLN $COMIN_ENS/${APREFIX_ENKF}atmi00${FHR}.ensmean$ASUFFIX ./atminc_ensmean + fi -# Compute ensemble mean analysis -DATAPATH="./" -ATMANLNAME="atmanl" -ATMANLMEANNAME="atmanl_ensmean" + # Compute ensemble mean increment + DATAPATH="./" + ATMINCNAME="atminc" + ATMINCMEANNAME="atminc_ensmean" -export OMP_NUM_THREADS=$NTHREADS_ECEN + export OMP_NUM_THREADS=$NTHREADS_ECEN -$NCP $GETATMENSMEANEXEC $DATA -$APRUN_ECEN ${DATA}/$(basename $GETATMENSMEANEXEC) $DATAPATH $ATMANLMEANNAME $ATMANLNAME $NMEM_ENKF -rc=$? + $NCP $GETATMENSMEANEXEC $DATA + $APRUN_ECEN ${DATA}/$(basename $GETATMENSMEANEXEC) $DATAPATH $ATMINCMEANNAME $ATMINCNAME $NMEM_ENKF + rc=$? -export ERR=$rc -export err=$ERR -$ERRSCRIPT || exit 2 + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 2 + + # If available, link to ensemble mean guess. Otherwise, compute ensemble mean guess + if [ -s $COMIN_GES_ENS/${GPREFIX}atmf00${FHR}.ensmean$GSUFFIX ]; then + $NLN $COMIN_GES_ENS/${GPREFIX}atmf00${FHR}.ensmean$GSUFFIX ./atmges_ensmean + else + DATAPATH="./" + ATMGESNAME="atmges" + ATMGESMEANNAME="atmges_ensmean" + + export OMP_NUM_THREADS=$NTHREADS_ECEN + + $NCP $GETATMENSMEANEXEC $DATA + $APRUN_ECEN ${DATA}/$(basename $GETATMENSMEANEXEC) $DATAPATH $ATMGESMEANNAME $ATMGESNAME $NMEM_ENKF + rc=$? + + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 2 + fi +fi -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}')} -JCAP_ENKF=${JCAP_ENKF:-$($NEMSIOGET atmanl_ensmean jcap | awk '{print $2}')} +if [ ${SUFFIX} = ".nc" ]; then + if [ $DO_CALC_INCREMENT = "YES" ]; then + LONB_ENKF=${LONB_ENKF:-$($NCLEN atmanl_ensmean grid_xt)} # get LONB + LATB_ENKF=${LATB_ENKF:-$($NCLEN atmanl_ensmean grid_yt)} # get LATB + LEVS_ENKF=${LEVS_ENKF:-$($NCLEN atmanl_ensmean pfull)} # get LEVS + else + LONB_ENKF=${LONB_ENKF:-$($NCLEN atminc_ensmean lon)} # get LONB + LATB_ENKF=${LATB_ENKF:-$($NCLEN atminc_ensmean lat)} # get LATB + LEVS_ENKF=${LEVS_ENKF:-$($NCLEN atminc_ensmean lev)} # get LEVS + fi + JCAP_ENKF=${JCAP_ENKF:--9999} # there is no jcap in these files +else + 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}')} + JCAP_ENKF=${JCAP_ENKF:-$($NEMSIOGET atmanl_ensmean jcap | awk '{print $2}')} +fi [ $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 @@ -173,31 +247,39 @@ JCAP_ENKF=${JCAP_ENKF:-$($NEMSIOGET atmanl_ensmean jcap | awk '{print $2}')} if [ $RECENTER_ENKF = "YES" ]; then # GSI EnVar analysis - ATMANL_GSI=${ATMANL_GSI:-$COMIN/${APREFIX}atmanl$ASUFFIX} - ATMANL_GSI_ENSRES=${ATMANL_GSI_ENSRES:-$COMIN/${APREFIX}atmanl.ensres$ASUFFIX} - - LONB=${LONB:-$($NEMSIOGET $ATMANL_GSI dimx | awk '{print $2}')} - LATB=${LATB:-$($NEMSIOGET $ATMANL_GSI dimy | awk '{print $2}')} - JCAP=${JCAP:-$($NEMSIOGET $ATMANL_GSI jcap | awk '{print $2}')} - [ $JCAP -eq -9999 -a $LATB -ne -9999 ] && JCAP=$((LATB-2)) + if [ $FHR -eq 6 ]; then + ATMANL_GSI=$COMIN/${APREFIX}atmanl$ASUFFIX + ATMANL_GSI_ENSRES=$COMIN/${APREFIX}atmanl.ensres$ASUFFIX + else + ATMANL_GSI=$COMIN/${APREFIX}atma00${FHR}$ASUFFIX + ATMANL_GSI_ENSRES=$COMIN/${APREFIX}atma00${FHR}.ensres$ASUFFIX + fi - # 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 + # if we already have a ensemble resolution GSI analysis then just link to it + if [ -f $ATMANL_GSI_ENSRES ]; then - $NLN $ATMANL_GSI atmanl_gsi_ensres + $NLN $ATMANL_GSI_ENSRES atmanl_gsi_ensres else $NLN $ATMANL_GSI atmanl_gsi $NLN $ATMANL_GSI_ENSRES atmanl_gsi_ensres - SIGLEVEL=${SIGLEVEL:-${FIXgsm}/global_hyblev.l${LEVS}.txt} + if [ ${SUFFIX} = ".nc" ]; then + $NLN $CHGRESNC chgres.x + chgresnml=chgres_nc_gauss.nml + nmltitle=chgres + else + $NLN $CHGRESNEMS chgres.x + chgresnml=fort.43 + nmltitle=nam + fi export OMP_NUM_THREADS=$NTHREADS_CHGRES - rm -f fort.43 - cat > fort.43 << EOF -&nam_setup + rm -f $chgresnml + cat > $chgresnml << EOF +&${nmltitle}_setup i_output=$LONB_ENKF j_output=$LATB_ENKF input_file="atmanl_gsi" @@ -206,8 +288,8 @@ if [ $RECENTER_ENKF = "YES" ]; then vcoord_file="$SIGLEVEL" / EOF - - $APRUN_CHGRES $CHGRESEXEC + cat $chgresnml + $APRUN_CHGRES ./chgres.x rc=$? export ERR=$rc @@ -216,48 +298,92 @@ EOF fi - ################################################################################ - # Recenter ensemble member atmospheric analyses about hires analysis + if [ $DO_CALC_INCREMENT = "YES" ]; then + ################################################################################ + # Recenter ensemble member atmospheric analyses about hires analysis - FILENAMEIN="atmanl" - FILENAME_MEANIN="atmanl_ensmean" # EnKF ensemble mean analysis - FILENAME_MEANOUT="atmanl_gsi_ensres" # recenter around GSI analysis at ensemble resolution - FILENAMEOUT="ratmanl" + FILENAMEIN="atmanl" + FILENAME_MEANIN="atmanl_ensmean" # EnKF ensemble mean analysis + FILENAME_MEANOUT="atmanl_gsi_ensres" # recenter around GSI analysis at ensemble resolution + FILENAMEOUT="ratmanl" - export OMP_NUM_THREADS=$NTHREADS_ECEN + export OMP_NUM_THREADS=$NTHREADS_ECEN - $NCP $RECENATMEXEC $DATA - $APRUN_ECEN ${DATA}/$(basename $RECENATMEXEC) $FILENAMEIN $FILENAME_MEANIN $FILENAME_MEANOUT $FILENAMEOUT $NMEM_ENKF - rc=$? + $NCP $RECENATMEXEC $DATA + $APRUN_ECEN ${DATA}/$(basename $RECENATMEXEC) $FILENAMEIN $FILENAME_MEANIN $FILENAME_MEANOUT $FILENAMEOUT $NMEM_ENKF + rc=$? - export ERR=$rc - export err=$ERR - $ERRSCRIPT || exit 2 + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 2 + + # Optionally alert recentered files + 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 $COMOUT_ENS/$memchar/${APREFIX}ratmanl$ASUFFIX + done + fi + else + ################################################################################ + # Recenter ensemble member atmospheric increments about hires analysis - # Optionally alert recentered files - 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 $COMOUT_ENS/$memchar/${APREFIX}ratmanl$ASUFFIX - done - fi + FILENAMEIN="atminc" + FILENAME_INCMEANIN="atminc_ensmean" # EnKF ensemble mean increment + FILENAME_GESMEANIN="atmges_ensmean" # EnKF ensemble mean guess + FILENAME_GSIDET="atmanl_gsi_ensres" # recenter around GSI analysis at ensemble resolution + FILENAMEOUT="ratminc" + + export OMP_NUM_THREADS=$NTHREADS_ECEN + + # make the small namelist file for incvars_to_zero + + rm recenter.nml + cat > recenter.nml << EOF +&recenter + incvars_to_zero = $INCREMENTS_TO_ZERO +/ +EOF +cat recenter.nml + $NCP $RECENATMEXEC $DATA + $APRUN_ECEN ${DATA}/$(basename $RECENATMEXEC) $FILENAMEIN $FILENAME_INCMEANIN $FILENAME_GSIDET $FILENAMEOUT $NMEM_ENKF $FILENAME_GESMEANIN + rc=$? + + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 2 + + # Optionally alert recentered files + 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 $COMOUT_ENS/$memchar/${APREFIX}ratminc$ASUFFIX + done + fi + fi fi ################################################################################ # Calculate ensemble analysis increment +if [ $DO_CALC_INCREMENT = "YES" ]; then + if [ $RECENTER_ENKF = "YES" ]; then + ATMANLNAME='ratmanl' + else + ATMANLNAME='atmanl' + fi -if [ $RECENTER_ENKF = "YES" ]; then - ATMANLNAME='ratmanl' -else - ATMANLNAME='atmanl' -fi + export OMP_NUM_THREADS=$NTHREADS_CALCINC + if [ ${SUFFIX} = ".nc" ]; then -export OMP_NUM_THREADS=$NTHREADS_CALCINC -$NCP $CALCINCEXEC $DATA + CALCINCEXEC=$CALCINCNCEXEC + else + CALCINCEXEC=$CALCINCNEMSEXEC + fi + $NCP $CALCINCEXEC $DATA -rm calc_increment.nml -cat > calc_increment.nml << EOF + rm calc_increment.nml + cat > calc_increment.nml << EOF &setup datapath = './' analysis_filename = '$ATMANLNAME' @@ -273,129 +399,14 @@ cat > calc_increment.nml << EOF EOF cat calc_increment.nml -$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 - -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) -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)) -LATB_CASE=$((res*2)) -LONB_CASE=$((res*4)) - -# Global cycle requires these files -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 - snoprv=$($GETGESSH -q -t snogrb_$JCAP_CASE -e $gesenvir -n $GDUMP -v $GDATE) -else - snoprv=${snoprv:-$FNSNOG} -fi - -if [ $($WGRIB -4yr $FNSNOA 2>/dev/null | grep -i snowc | awk -F: '{print $3}' | awk -F= '{print $2}') -le \ - $($WGRIB -4yr $snoprv 2>/dev/null | grep -i snowc | awk -F: '{print $3}' | awk -F= '{print $2}') ] ; then - export FNSNOA=" " - export CYCLVARS="FSNOL=99999.,FSNOS=99999.," -else - export SNOW_NUDGE_COEFF=${SNOW_NUDGE_COEFF:-0.} - export CYCLVARS="FSNOL=${SNOW_NUDGE_COEFF},$CYCLVARS" -fi - -if [ $DONST = "YES" ]; then - export NST_ANL=".true." - export GSI_FILE=${GSI_FILE:-$COMIN/${APREFIX}dtfanl.nc} -else - export NST_ANL=".false." - export GSI_FILE="NULL" -fi - -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 + $APRUN_CALCINC ${DATA}/$(basename $CALCINCEXEC) + rc=$? + export ERR=$rc + export err=$rc + $ERRSCRIPT || exit 4 fi - -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/$PDY.${cyc}0000.sfc_data.tile${n}.nc $DATA/fnbgsi.$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 - - done - - $CYCLESH - rc=$? - export ERR=$rc - export err=$ERR - $ERRSCRIPT || exit 11 - -done +done # loop over analysis times in window ################################################################################ diff --git a/scripts/exglobal_enkf_surface_fv3gfs.sh.ecf b/scripts/exglobal_enkf_surface_fv3gfs.sh.ecf new file mode 100755 index 0000000000..f4dd0a1e19 --- /dev/null +++ b/scripts/exglobal_enkf_surface_fv3gfs.sh.ecf @@ -0,0 +1,225 @@ +#!/bin/ksh +################################################################################ +#### UNIX Script Documentation Block +# . . +# Script name: exglobal_enkf_surface_fv3gfs.sh.ecf +# Script description: generate ensemble surface analyses on tiles +# +# Author: Rahul Mahajan Org: NCEP/EMC Date: 2017-03-02 +# +# Abstract: This script generates ensemble surface analyses on tiles +# +# $Id$ +# +# Attributes: +# Language: POSIX shell +# Machine: WCOSS-Cray/Theia +# +################################################################################ + +# Set environment. +VERBOSE=${VERBOSE:-"YES"} +if [ $VERBOSE = "YES" ]; then + echo $(date) EXECUTING $0 $* >&2 + set -x +fi + +# Directories. +pwd=$(pwd) +export NWPROD=${NWPROD:-$pwd} +export HOMEgfs=${HOMEgfs:-$NWPROD} +HOMEgsi=${HOMEgsi:-$NWPROD} +export DATA=${DATA:-$pwd} +COMIN=${COMIN:-$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} +COMOUT_ENS=${COMOUT_ENS:-$COMIN_ENS} + +CDATE=${CDATE:-"2010010100"} +DONST=${DONST:-"NO"} +DOSFCANL_ENKF=${DOSFCANL_ENKF:-"YES"} + +export CASE=${CASE:-384} +ntiles=${ntiles:-6} + +# Utilities +ERRSCRIPT=${ERRSCRIPT:-'eval [[ $err = 0 ]]'} +NCP=${NCP:-"/bin/cp -p"} +NLN=${NLN:-"/bin/ln -sf"} +NEMSIOGET=${NEMSIOGET:-${NWPROD}/exec/nemsio_get} +NCLEN=${NCLEN:-$HOMEgfs/ush/getncdimlen} + +# Scripts + +# Executables. + +# Files. +OPREFIX=${OPREFIX:-""} +OSUFFIX=${OSUFFIX:-""} +APREFIX=${APREFIX:-""} +APREFIX_ENKF=${APREFIX_ENKF:-$APREFIX} +ASUFFIX=${ASUFFIX:-$SUFFIX} +GPREFIX=${GPREFIX:-""} +GSUFFIX=${GSUFFIX:-$SUFFIX} + +# Variables +NMEM_ENKF=${NMEM_ENKF:-80} +DOIAU=${DOIAU_ENKF:-"NO"} + +# 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.,"} +export FHOUR=${FHOUR:-0} +export DELTSFC=${DELTSFC:-6} + +APRUN_ESFC=${APRUN_ESFC:-${APRUN:-""}} +NTHREADS_ESFC=${NTHREADS_ESFC:-${NTHREADS:-1}} + + +################################################################################ +# Preprocessing +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi +cd $DATA || exit 99 + + +################################################################################ +# Update surface fields in the FV3 restart's using global_cycle. + +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) +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)) +LATB_CASE=$((res*2)) +LONB_CASE=$((res*4)) + +# Global cycle requires these files +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 + snoprv=$($GETGESSH -q -t snogrb_$JCAP_CASE -e $gesenvir -n $GDUMP -v $GDATE) +else + snoprv=${snoprv:-$FNSNOG} +fi + +if [ $($WGRIB -4yr $FNSNOA 2>/dev/null | grep -i snowc | awk -F: '{print $3}' | awk -F= '{print $2}') -le \ + $($WGRIB -4yr $snoprv 2>/dev/null | grep -i snowc | awk -F: '{print $3}' | awk -F= '{print $2}') ] ; then + export FNSNOA=" " + export CYCLVARS="FSNOL=99999.,FSNOS=99999.," +else + export SNOW_NUDGE_COEFF=${SNOW_NUDGE_COEFF:-0.} + export CYCLVARS="FSNOL=${SNOW_NUDGE_COEFF},$CYCLVARS" +fi + +if [ $DONST = "YES" ]; then + export NST_ANL=".true." + export GSI_FILE=${GSI_FILE:-$COMIN/${APREFIX}dtfanl.nc} +else + export NST_ANL=".false." + export GSI_FILE="NULL" +fi + +export APRUNCY=${APRUN_CYCLE:-$APRUN_ESFC} +export OMP_NUM_THREADS_CY=${NTHREADS_CYCLE:-$NTHREADS_ESFC} +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 + +if [ $DOSFCANL_ENKF = "YES" ]; then + 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/$PDY.${cyc}0000.sfc_data.tile${n}.nc $DATA/fnbgsi.$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 + + done + + $CYCLESH + rc=$? + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 11 + + done +fi + +################################################################################ + +################################################################################ +# Postprocessing +cd $pwd +[[ $mkdata = "YES" ]] && rm -rf $DATA +set +x +if [ $VERBOSE = "YES" ]; then + echo $(date) EXITING $0 with return code $err >&2 +fi +exit $err diff --git a/scripts/exglobal_enkf_update_fv3gfs.sh.ecf b/scripts/exglobal_enkf_update_fv3gfs.sh.ecf index 1e53ce7c99..24d273813f 100755 --- a/scripts/exglobal_enkf_update_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_update_fv3gfs.sh.ecf @@ -40,6 +40,7 @@ NCP=${NCP:-"/bin/cp -p"} NLN=${NLN:-"/bin/ln -sf"} ERRSCRIPT=${ERRSCRIPT:-'eval [[ $err = 0 ]]'} NEMSIOGET=${NEMSIOGET:-$NWPROD/utils/exec/nemsio_get} +NCLEN=${NCLEN:-$HOMEgfs/ush/getncdimlen} USE_CFP=${USE_CFP:-"NO"} APRUNCFP=${APRUNCFP:-""} APRUN_ENKF=${APRUN_ENKF:-${APRUN:-""}} @@ -53,9 +54,9 @@ CDATE=${CDATE:-"2001010100"} # Filenames. GPREFIX=${GPREFIX:-""} -GSUFFIX=${GSUFFIX:-""} +GSUFFIX=${GSUFFIX:-$SUFFIX} APREFIX=${APREFIX:-""} -ASUFFIX=${ASUFFIX:-""} +ASUFFIX=${ASUFFIX:-$SUFFIX} SMOOTH_ENKF=${SMOOTH_ENKF:-"YES"} @@ -66,32 +67,58 @@ RADSTAT=${RADSTAT:-${APREFIX}radstat} ENKFSTAT=${ENKFSTAT:-${APREFIX}enkfstat} # Namelist parameters +USE_CORRELATED_OBERRS=${USE_CORRELATED_OBERRS:-"NO"} NMEM_ENKF=${NMEM_ENKF:-80} NAM_ENKF=${NAM_ENKF:-""} SATOBS_ENKF=${SATOBS_ENKF:-""} OZOBS_ENKF=${OZOBS_ENKF:-""} +use_correlated_oberrs=${use_correlated_oberrs:-".false."} +if [ $USE_CORRELATED_OBERRS == "YES" ]; then + use_correlated_oberrs=".true." +fi 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"} +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."} +lobsdiag_forenkf=${lobsdiag_forenkf:-".false."} +write_spread_diag=${write_spread_diag:-".false."} +cnvw_option=${cnvw_option:-".false."} +netcdf_diag=${netcdf_diag:-".true."} modelspace_vloc=${modelspace_vloc:-".false."} # if true, 'vlocal_eig.dat' is needed IAUFHRS_ENKF=${IAUFHRS_ENKF:-6} +DO_CALC_INCREMENT=${DO_CALC_INCREMENT:-"NO"} +INCREMENTS_TO_ZERO=${INCREMENTS_TO_ZERO:-"'NONE'"} ################################################################################ ATMGES_ENSMEAN=$COMIN_GES_ENS/${GPREFIX}atmf006.ensmean${GSUFFIX} -LEVS_ENKF=${LEVS_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimz | awk '{print $2}')} -LATB_ENKF=${LATB_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimy | awk '{print $2}')} -LONB_ENKF=${LONB_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimx | awk '{print $2}')} +if [ $SUFFIX = ".nc" ]; then + LONB_ENKF=${LONB_ENKF:-$($NCLEN $ATMGES_ENSMEAN grid_xt)} # get LONB_ENKF + LATB_ENKF=${LATB_ENKF:-$($NCLEN $ATMGES_ENSMEAN grid_yt)} # get LATB_ENFK + LEVS_ENKF=${LEVS_ENKF:-$($NCLEN $ATMGES_ENSMEAN pfull)} # get LEVS_ENFK + use_gfs_ncio=".true." + use_gfs_nemsio=".false." + paranc=${paranc:-".true."} + if [ $DO_CALC_INCREMENT = "YES" ]; then + write_fv3_incr=".false." + else + write_fv3_incr=".true." + WRITE_INCR_ZERO="incvars_to_zero= $INCREMENTS_TO_ZERO," + fi +else + LEVS_ENKF=${LEVS_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimz | awk '{print $2}')} + LATB_ENKF=${LATB_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimy | awk '{print $2}')} + LONB_ENKF=${LONB_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimx | awk '{print $2}')} + use_gfs_ncio=".false." + use_gfs_nemsio=".true." + paranc=${paranc:-".false."} +fi LATA_ENKF=${LATA_ENKF:-$LATB_ENKF} LONA_ENKF=${LONA_ENKF:-$LONB_ENKF} @@ -160,7 +187,7 @@ EOFuntar fi ################################################################################ -# Ensemble guess, observational data and analysis +# Ensemble guess, observational data and analyses/increments flist="$CNVSTAT $OZNSTAT $RADSTAT" if [ $USE_CFP = "YES" ]; then @@ -174,28 +201,44 @@ 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 - echo "$DATA/untar.sh $memchar" | tee -a $DATA/mp_untar.sh - else - for ftype in $flist; do - fname=$COMOUT_ANL_ENS/$memchar/$ftype - tar -xvf $fname - done + if [ $lobsdiag_forenkf = ".false." ]; then + if [ $USE_CFP = "YES" ]; then + echo "$DATA/untar.sh $memchar" | tee -a $DATA/mp_untar.sh + else + for ftype in $flist; do + fname=$COMOUT_ANL_ENS/$memchar/$ftype + tar -xvf $fname + done + fi fi mkdir -p $COMOUT_ANL_ENS/$memchar - for FHR in $nfhrs; do + for FHR in $nfhrs; do $NLN $COMIN_GES_ENS/$memchar/${GPREFIX}atmf00${FHR}${ENKF_SUFFIX}${GSUFFIX} sfg_${CDATE}_fhr0${FHR}_${memchar} + if [ $cnvw_option = ".true." ]; then + $NLN $COMIN_GES_ENS/$memchar/${GPREFIX}sfcf00${FHR}${GSUFFIX} sfgsfc_${CDATE}_fhr0${FHR}_${memchar} + fi if [ $FHR -eq 6 ]; then - $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atmanl${ASUFFIX} sanl_${CDATE}_fhr0${FHR}_${memchar} + if [ $DO_CALC_INCREMENT = "YES" ]; then + $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atmanl${ASUFFIX} sanl_${CDATE}_fhr0${FHR}_${memchar} + else + $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atminc${ASUFFIX} incr_${CDATE}_fhr0${FHR}_${memchar} + fi else - $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atmanl00${FHR}${ASUFFIX} sanl_${CDATE}_fhr0${FHR}_${memchar} + if [ $DO_CALC_INCREMENT = "YES" ]; then + $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atma00${FHR}${ASUFFIX} sanl_${CDATE}_fhr0${FHR}_${memchar} + else + $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atmi00${FHR}${ASUFFIX} incr_${CDATE}_fhr0${FHR}_${memchar} + fi fi done done # Ensemble mean guess -for FHR in $nfhrs; do +for FHR in $nfhrs; do $NLN $COMIN_GES_ENS/${GPREFIX}atmf00${FHR}.ensmean${GSUFFIX} sfg_${CDATE}_fhr0${FHR}_ensmean + if [ $cnvw_option = ".true." ]; then + $NLN $COMIN_GES_ENS/${GPREFIX}sfcf00${FHR}.ensmean${GSUFFIX} sfgsfc_${CDATE}_fhr0${FHR}_ensmean + fi done if [ $USE_CFP = "YES" ]; then @@ -229,14 +272,17 @@ cat > enkf.nml << EOFnml nlons=$LONA_ENKF,nlats=$LATA_ENKF,nlevs=$LEVS_ENKF,nanals=$NMEM_ENKF, deterministic=.true.,sortinc=.true.,lupd_satbiasc=.false., reducedgrid=${reducedgrid},readin_localization=${readin_localization_enkf}., - use_gfs_nemsio=.true.,imp_physics=$imp_physics,lupp=$lupp, + use_gfs_nemsio=${use_gfs_nemsio},use_gfs_ncio=${use_gfs_ncio},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, + use_correlated_oberrs=${use_correlated_oberrs}, + netcdf_diag=$netcdf_diag,cnvw_option=$cnvw_option, + paranc=$paranc,write_fv3_incr=$write_fv3_incr, + $WRITE_INCR_ZERO $NAM_ENKF / &satobs_enkf @@ -307,6 +353,9 @@ cat > enkf.nml << EOFnml 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', + sattypes_rad(68)= 'ahi_himawari8', dsis(68)= 'ahi_himawari8', + sattypes_rad(69)= 'abi_g16', dsis(69)= 'abi_g16', + sattypes_rad(70)= 'abi_g17', dsis(70)= 'abi_g17', $SATOBS_ENKF / &ozobs_enkf @@ -332,56 +381,8 @@ 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 +$APRUN_ENKF $PGM 1>stdout 2>stderr +rc=$? export ERR=$rc export err=$ERR diff --git a/scripts/exglobal_innovate_obs_fv3gfs.sh.ecf b/scripts/exglobal_innovate_obs_fv3gfs.sh.ecf index 942f4ea756..e7e888c38e 100755 --- a/scripts/exglobal_innovate_obs_fv3gfs.sh.ecf +++ b/scripts/exglobal_innovate_obs_fv3gfs.sh.ecf @@ -42,7 +42,7 @@ ANALYSISSH=${ANALYSISSH:-$HOMEgsi/scripts/exglobal_analysis_fv3gfs.sh.ecf} # Prefix and Suffix Variables. export APREFIX=${APREFIX:-""} -export ASUFFIX=${ASUFFIX:-""} +export ASUFFIX=${ASUFFIX:-$SUFFIX} # Select obs export RUN_SELECT=${RUN_SELECT:-"YES"} @@ -97,7 +97,9 @@ export DIAG_COMPRESS=${DIAG_COMPRESS:-"NO"} export DIAG_TARBALL=${DIAG_TARBALL:-"YES"} export DOHYBVAR="NO" export DO_CALC_INCREMENT="NO" +export DO_CALC_ANALYSIS="NO" export USE_CORRELATED_OBERRS="NO" +export write_fv3_increment=".false." # 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" diff --git a/src/enkf/CMakeLists.txt b/src/enkf/CMakeLists.txt index b7e2ba3930..2b126c2e1a 100644 --- a/src/enkf/CMakeLists.txt +++ b/src/enkf/CMakeLists.txt @@ -35,7 +35,7 @@ if(BUILD_ENKF) 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 statevec.f90 controlvec.f90 observer_${ENKF_SUFFIX}.f90 gridio_${ENKF_SUFFIX}.f90 gridinfo_${ENKF_SUFFIX}.f90 expand_ens.f90 @@ -47,7 +47,7 @@ if(BUILD_ENKF) read_locinfo.f90 enkf_main.f90 inflation.f90 - letkf.F90 + letkf.f90 quicksort.f90 radbias.f90 loadbal.f90 @@ -62,7 +62,7 @@ if(BUILD_ENKF) 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_Fortran_INCLUDE_PATH} ${CORE_INCS} ${NETCDF_INCLUDES} ${NCDIAG_INCS} ) + 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} ${FV3GFS_NCIO_INCS}) link_directories(${MPI_Fortran_LIBRARIES}) set_source_files_properties( ${ENKF_SRCS} PROPERTIES COMPILE_FLAGS ${ENKF_Fortran_FLAGS} ) @@ -79,7 +79,7 @@ if(BUILD_ENKF) 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}) + ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${GSI_LDFLAGS} ${CORE_BUILT} ${CORE_LIBRARIES} ${CORE_BUILT} ${NCDIAG_LIBRARIES} ${FV3GFS_NCIO_LIBRARIES}) install(TARGETS ${ENKFEXEC} enkfdeplib enkflib RUNTIME DESTINATION ${CMAKE_INSTALL_PREFIX}/bin LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib diff --git a/src/enkf/README.shmem b/src/enkf/README.shmem deleted file mode 100644 index 733ded1ac9..0000000000 --- a/src/enkf/README.shmem +++ /dev/null @@ -1,14 +0,0 @@ -Currently, the LETKF requires that a copy of the entire -observation space prior ensemble be allocated on every -MPI task. This is a single precision real array of -size nanals*nobstot, where nanals is the ensemble size -and nobstot is the number of obs assimilated -(currently about 3.e6). To reduce the memory consumption -of the LETKF, the ability of MPI-3 to allocate -shared memory that can be accessed by all tasks -on a node can be used. The allows only one copy -of the observation space prior ensemble to be allocated -on each node. To enable this feature, edit -Makefile.conf and uncomment the line with "-DMPI3" -and recompile (using an mpi implementation that supports -mpi-3). diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90 index 90eb5483ef..ddd9ded945 100644 --- a/src/enkf/controlvec.f90 +++ b/src/enkf/controlvec.f90 @@ -42,13 +42,18 @@ module controlvec ! !$$$ -use mpisetup -use gridio, only: readgriddata, writegriddata +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8 + +use gridio, only: readgriddata, readgriddata_pnc, writegriddata, writegriddata_pnc, & + writeincrement, writeincrement_pnc 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 + nanals_per_iotask, ntasks_io, nanal1, nanal2, & + fgsfcfileprefixes, paranc, write_fv3_incr use kinds, only: r_kind, i_kind, r_double, r_single use mpeu_util, only: gettablesize, gettable, getindex use constants, only: max_varname_length @@ -206,11 +211,19 @@ subroutine read_control() ! 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)) +allocate(grdin(npts,ncdim,nbackgrounds,nanals_per_iotask)) +allocate(qsat(npts,nlevs,nbackgrounds,nanals_per_iotask)) +if (paranc) then if (nproc == 0) t1 = mpi_wtime() - call readgriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds,fgfileprefixes,reducedgrid,grdin,qsat) + call readgriddata_pnc(cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, & + fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat) +end if +if (nproc <= ntasks_io-1) then + if (.not. paranc) then + if (nproc == 0) t1 = mpi_wtime() + call readgriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, & + fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat) + end if !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat) if (use_qsatensmean) then allocate(qsatmean(npts,nlevs,nbackgrounds)) @@ -341,13 +354,31 @@ subroutine write_control(no_inflate_flag) enddo endif end if - call writegriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,grdin,no_inflate_flag) + if (.not. paranc) then + if (write_fv3_incr) then + call writeincrement(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,grdin,no_inflate_flag) + else + call writegriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,grdin,no_inflate_flag) + end if + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in write_control on root',t2-t1,'secs' + endif + end if + +end if ! io task + +if (paranc) then + if (write_fv3_incr) then + call writeincrement_pnc(cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,grdin,no_inflate_flag) + else + call writegriddata_pnc(cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,grdin,no_inflate_flag) + end if if (nproc == 0) then t2 = mpi_wtime() print *,'time in write_control on root',t2-t1,'secs' endif - -end if ! io task +end if end subroutine write_control @@ -357,9 +388,9 @@ subroutine controlvec_cleanup() 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) +if (allocated(grdin)) deallocate(grdin) +if (allocated(qsat)) deallocate(qsat) +if (allocated(qsatmean)) deallocate(qsatmean) call gridinfo_cleanup() end subroutine controlvec_cleanup diff --git a/src/enkf/enkf.f90 b/src/enkf/enkf.f90 index 7ddba32075..248fe87717 100644 --- a/src/enkf/enkf.f90 +++ b/src/enkf/enkf.f90 @@ -103,7 +103,10 @@ module enkf ! !$$$ -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max,mpi_realkind,& + mpi_2real,mpi_minloc,mpi_real use covlocal, only: taper use kinds, only: r_double,i_kind,r_single,r_single use kdtree2_module, only: kdtree2_r_nearest, kdtree2_result diff --git a/src/enkf/enkf_main.f90 b/src/enkf/enkf_main.f90 index 9500147933..be7df09608 100644 --- a/src/enkf/enkf_main.f90 +++ b/src/enkf/enkf_main.f90 @@ -72,13 +72,14 @@ program enkf_main !$$$ use kinds, only: r_kind,r_double,i_kind + use mpimod, only : mpi_comm_world ! reads namelist parameters. 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, & - mpi_wtime, mpi_comm_world + mpi_wtime ! obs and ob priors, associated metadata. use enkf_obsmod, only : readobs, write_obsstats, obfit_prior, obsprd_prior, & nobs_sat, obfit_post, obsprd_post, obsmod_cleanup diff --git a/src/enkf/enkf_obs_sensitivity.f90 b/src/enkf/enkf_obs_sensitivity.f90 index 10735aaaba..95aa71cf06 100644 --- a/src/enkf/enkf_obs_sensitivity.f90 +++ b/src/enkf/enkf_obs_sensitivity.f90 @@ -28,7 +28,9 @@ module enkf_obs_sensitivity ! !$$$ end documentation block ! ----------------------------------------------------------------------------- -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max,mpi_realkind use kinds, only: r_single,r_kind,r_double,i_kind use params, only: fso_calculate,latbound,nlevs,nanals,datestring, & lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh, & diff --git a/src/enkf/enkf_obsmod.f90 b/src/enkf/enkf_obsmod.f90 index 310f142e61..06984bb080 100644 --- a/src/enkf/enkf_obsmod.f90 +++ b/src/enkf/enkf_obsmod.f90 @@ -98,7 +98,9 @@ module enkf_obsmod ! !$$$ -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max use kinds, only : r_kind, r_double, i_kind, r_single use constants, only: zero, one, deg2rad, rad2deg, rd, cp, pi use params, only: & @@ -106,11 +108,12 @@ module enkf_obsmod lnsigcutoffnh, lnsigcutoffsh, lnsigcutofftr, corrlengthnh,& corrlengthtr, corrlengthsh, obtimelnh, obtimeltr, obtimelsh,& lnsigcutoffsatnh, lnsigcutoffsatsh, lnsigcutoffsattr,& - varqc, huber, zhuberleft, zhuberright,& + varqc, huber, zhuberleft, zhuberright, modelspace_vloc, & lnsigcutoffpsnh, lnsigcutoffpssh, lnsigcutoffpstr, neigv use state_vectors, only: init_anasv use mpi_readobs, only: mpi_getobs +use, intrinsic :: iso_c_binding implicit none private @@ -134,11 +137,14 @@ module enkf_obsmod 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. -! same goes for anal_ob_modens when modelspace_vloc=T. -real(r_single), public, allocatable, dimension(:,:) :: anal_ob, anal_ob_modens +! ob-space prior ensemble +! pointers used for MPI-3 shared memory manipulations. +! allocated and filled in mpi_readobs +real(r_single),public,pointer, dimension(:,:) :: anal_ob ! Fortran pointer +type(c_ptr) :: anal_ob_cp ! C pointer +real(r_single),public,pointer, dimension(:,:) :: anal_ob_modens ! Fortran pointer +type(c_ptr) :: anal_ob_modens_cp ! C pointer +integer :: shm_win, shm_win2 contains @@ -183,7 +189,8 @@ subroutine readobs() 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) + anal_ob,anal_ob_modens,anal_ob_cp,anal_ob_modens_cp, & + shm_win,shm_win2, indxsat, nanals, neigv) tdiff = mpi_wtime()-t1 call mpi_reduce(tdiff,tdiffmax,1,mpi_real4,mpi_max,0,mpi_comm_world,ierr) @@ -248,6 +255,7 @@ subroutine readobs() obloc(3,nob) = sin(radlat) deglat = obloclat(nob) ! get limits on corrlength,lnsig,and obtime + if (.not. modelspace_vloc) then if (nob > nobs_conv+nobs_oz) then lnsigl(nob) = latval(deglat,lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh) else if (obtype(nob)(1:3) == ' ps') then @@ -255,6 +263,7 @@ subroutine readobs() else lnsigl(nob)=latval(deglat,lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh) end if + endif corrlengthsq(nob)=latval(deglat,corrlengthnh,corrlengthtr,corrlengthsh)**2 obtimel(nob)=latval(deglat,obtimelnh,obtimeltr,obtimelsh) end do @@ -418,6 +427,7 @@ subroutine channelstats end subroutine channelstats subroutine obsmod_cleanup() +integer ierr ! deallocate module-level allocatable arrays if (allocated(obsprd_prior)) deallocate(obsprd_prior) if (allocated(obfit_prior)) deallocate(obfit_prior) @@ -442,9 +452,15 @@ subroutine obsmod_cleanup() if (allocated(obtype)) deallocate(obtype) if (allocated(probgrosserr)) deallocate(probgrosserr) if (allocated(prpgerr)) deallocate(prpgerr) -if (allocated(anal_ob)) deallocate(anal_ob) -if (allocated(anal_ob_modens)) deallocate(anal_ob_modens) if (allocated(diagused)) deallocate(diagused) +! free shared memory segement, fortran pointer to that memory. +nullify(anal_ob) +call MPI_Barrier(mpi_comm_world,ierr) +call MPI_Win_free(shm_win, ierr) +if (neigv > 0) then + nullify(anal_ob_modens) + call MPI_Win_free(shm_win2, ierr) +endif end subroutine obsmod_cleanup diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90 index cccf828cc6..7fdb2f67b0 100644 --- a/src/enkf/gridinfo_gfs.f90 +++ b/src/enkf/gridinfo_gfs.f90 @@ -43,8 +43,9 @@ module gridinfo ! !$$$ -use mpisetup, only: nproc, mpi_integer, mpi_real4, mpi_comm_world -use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio, fgfileprefixes +use mpisetup, only: nproc, mpi_integer, mpi_real4 +use mpimod, only: mpi_comm_world +use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio,use_gfs_ncio,fgfileprefixes 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 specmod, only: sptezv_s, sptez_s, init_spec_vars, isinitialized, asin_gaulats, & @@ -77,8 +78,12 @@ subroutine getgridinfo(fileprefix, reducedgrid) use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_close,& nemsio_getfilehead,nemsio_getheadvar,& nemsio_readrecv,nemsio_init, nemsio_realkind +use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + read_attribute, close_dataset, get_dim, read_vardata implicit none +type(Dataset) :: dset +type(Dimension) :: londim,latdim,levdim character(len=120), intent(in) :: fileprefix logical, intent(in) :: reducedgrid @@ -86,7 +91,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) character(len=500) filename integer(i_kind) iret,i,j,nlonsin,nlatsin real(r_kind), allocatable, dimension(:) :: ak,bk,spressmn,tmpspec -real(r_kind), allocatable, dimension(:,:) :: pressimn,presslmn +real(r_kind), allocatable, dimension(:,:) :: pressimn,presslmn,values_2d real(r_single),allocatable,dimension(:,:,:) :: nems_vcoord real(r_kind) kap,kapr,kap1 real(nemsio_realkind), dimension(nlons*nlats) :: nems_wrk @@ -100,8 +105,8 @@ subroutine getgridinfo(fileprefix, reducedgrid) kap1 = kap + one nlevs_pres=nlevs+1 if (nproc .eq. 0) then +filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" if (use_gfs_nemsio) then - 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, ', file: ', trim(filename) @@ -129,8 +134,19 @@ subroutine getgridinfo(fileprefix, reducedgrid) print *,'got',nlonsin,nlatsin,nlevsin call stop2(23) end if +else if (use_gfs_ncio) then + dset = open_dataset(filename) + londim = get_dim(dset,'grid_xt'); nlonsin = londim%len + latdim = get_dim(dset,'grid_yt'); nlatsin = latdim%len + levdim = get_dim(dset,'pfull'); nlevsin = levdim%len + idvc = 2; ntrunc = nlatsin-2 + if (nlons /= nlonsin .or. nlats /= nlatsin .or. nlevs /= nlevsin) then + print *,'incorrect dims in netcdf file' + print *,'expected',nlons,nlats,nlevs + print *,'got',nlonsin,nlatsin,nlevsin + call stop2(23) + end if else - filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" ! define sighead on all tasks. call sigio_sropen(iunit,trim(filename),iret) if (iret /= 0) then @@ -205,6 +221,23 @@ subroutine getgridinfo(fileprefix, reducedgrid) call nemsio_close(gfile, iret=iret) ptop = ak(nlevs+1) deallocate(ak,bk) + else if (use_gfs_ncio) then + call read_vardata(dset, 'pressfc', values_2d,errcode=iret) + if (iret /= 0) then + print *,'error reading ps in gridinfo_gfs' + call stop2(11) + endif + ! convert to 1d array, units to millibars, flip so lats go N to S. + spressmn = 0.01_r_kind*reshape(values_2d,(/nlons*nlats/)) + call read_attribute(dset, 'ak', ak) + call read_attribute(dset, 'bk', bk) + call close_dataset(dset) + ! pressure at interfaces + do k=1,nlevs+1 + pressimn(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*spressmn(:) + enddo + ptop = 0.01_r_kind*ak(1) + deallocate(ak,bk,values_2d) else ! get pressure from ensemble mean, ! distribute to all processors. diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index ff4987a5be..0d5216bc07 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -28,12 +28,13 @@ module gridio ! 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. +! 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 +! 2017-06-14 Adding functionality to optionally write non-inflated ensembles, +! a required input for EFSO calculations +! 2019-03-13 Add precipitation components +! 2019-07-10 Add convective clouds ! ! attributes: ! language: f95 @@ -41,25 +42,382 @@ module gridio !$$$ 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 + cliptracers,datapath,imp_physics,use_gfs_ncio,cnvw_option, & + nanals use kinds, only: i_kind,r_double,r_kind,r_single 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 mpisetup, only: nproc, numproc + use mpimod, only: mpi_comm_world, mpi_sum, mpi_real4, mpi_real8, mpi_rtype use mpeu_util, only: getindex implicit none private - public :: readgriddata, writegriddata + public :: readgriddata, readgriddata_pnc, writegriddata, writegriddata_pnc + public :: writeincrement, writeincrement_pnc + contains - subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,reducedgrid,grdin,qsat) + subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & + fileprefixes,filesfcprefixes,reducedgrid,grdin,qsat) + use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + quantize_data,read_attribute, close_dataset, get_dim, read_vardata + implicit none + + 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 + character(len=120), dimension(7), intent(in) :: filesfcprefixes + logical, intent(in) :: reducedgrid + real(r_single), dimension(npts,ndim,ntimes,1), intent(out) :: grdin + real(r_double), dimension(npts,nlevs,ntimes,1), intent(out) :: qsat + + character(len=500) :: filename,sfcfilename + 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,values_2d + real(r_kind), dimension(nlons*nlats) :: ug,vg + real(r_single), dimension(npts,nlevs) :: tv, q, cw + real(r_kind), dimension(ndimspec) :: vrtspec,divspec + real(r_kind), allocatable, dimension(:) :: psg,pstend,ak,bk + real(r_single),allocatable,dimension(:,:,:) :: ug3d,vg3d + type(Dataset) :: dset + type(Dimension) :: londim,latdim,levdim + + 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,iret,nb,i,imem,idvc,nlonsin,nlatsin,nlevsin,ne,nanal + logical ice + logical use_full_hydro + integer(i_kind), allocatable, dimension(:) :: mem_pe, lev_pe1, lev_pe2, iocomms + integer(i_kind) :: iope, ionumproc, iolevs, krev + integer(i_kind) :: ncstart(3), nccount(3) + + ! mpi gatherv things + integer(i_kind), allocatable, dimension(:) :: recvcounts, displs + real(r_single), dimension(nlons,nlats,nlevs) :: ug3d_0, vg3d_0 + + ! figure out what member to read and do MPI sub-communicator things + allocate(mem_pe(0:numproc-1)) + allocate(iocomms(nanals)) + imem = 1 + do i=0,numproc-1 + mem_pe(i) = imem + imem = imem + 1 + if (imem > nanals) imem = 1 + end do + nanal = mem_pe(nproc) + + call mpi_comm_split(mpi_comm_world, mem_pe(nproc), nproc, iocomms(mem_pe(nproc)), iret) + call mpi_comm_rank(iocomms(mem_pe(nproc)), iope, iret) + call mpi_comm_size(iocomms(mem_pe(nproc)), ionumproc, iret) + + ! figure out what levels to read on this sub-communicator's PE + allocate(lev_pe1(0:ionumproc-1)) + allocate(lev_pe2(0:ionumproc-1)) + iolevs = nlevs/ionumproc + do i=0,ionumproc-1 + lev_pe1(i) = (i * iolevs) + 1 + lev_pe2(i) = ((i + 1) * iolevs) + if (i == ionumproc-1) lev_pe2(i) = lev_pe2(i) + modulo(nlevs, ionumproc) + end do + ncstart = (/1, 1, lev_pe1(iope)/) + nccount = (/nlons, nlats, lev_pe2(iope) - lev_pe1(iope)+1/) + + ! some mpi gatherv calculations + allocate(recvcounts(ionumproc)) + allocate(displs(ionumproc)) + do i=0, ionumproc-1 + recvcounts(i+1) = (lev_pe2(i) - lev_pe1(i)+1)*nlons*nlats + displs(i+1) = ((lev_pe1(i)-1)*nlons*nlats) + end do + + + ! loop through times and do the read + ne = 1 + backgroundloop: do nb=1,ntimes + + write(charnanal,'(a3, i3.3)') 'mem', nanal + filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) + sfcfilename = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal) + if (use_gfs_ncio) then + dset = open_dataset(filename, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) + londim = get_dim(dset,'grid_xt'); nlonsin = londim%len + latdim = get_dim(dset,'grid_yt'); nlatsin = latdim%len + levdim = get_dim(dset,'pfull'); nlevsin = levdim%len + idvc=2 + else + print *, 'parallel read only supported for netCDF, stopping with error' + call stop2(23) + end if + ice = .false. ! calculate qsat w/resp to ice? + kap = rd/cp + kapr = cp/rd + kap1 = kap+one + + u_ind = getindex(vars3d, 'u') !< indices in the state or control 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 (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) + + allocate(pressi(nlons*nlats,nlevs+1)) + allocate(pslg(npts,nlevs)) + allocate(psg(nlons*nlats)) + if (pst_ind > 0) allocate(vmassdiv(nlons*nlats,nlevs),pstend(nlons*nlats)) + + call read_vardata(dset, 'pressfc', values_2d,errcode=iret) + if (iret /= 0) then + print *,'error reading ps' + call stop2(31) + endif + psg = 0.01_r_kind*reshape(values_2d,(/nlons*nlats/)) + call read_attribute(dset, 'ak', ak) + call read_attribute(dset, 'bk', bk) + if (nanal .eq. 1 .and. iope==0) then + print *,'time level ',nb + print *,'---------------' + endif + ! pressure at interfaces + do k=1,nlevs+1 + pressi(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*psg + if (nanal .eq. 1 .and. iope==0) print *,'netcdf, min/max pressi',k,minval(pressi(:,k)),maxval(pressi(:,k)) + enddo + deallocate(ak,bk,values_2d) + + call read_vardata(dset, 'ugrd', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading ugrd' + call stop2(22) + endif + call read_vardata(dset, 'vgrd', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading vgrd' + call stop2(23) + endif + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + call mpi_gatherv(vg3d, recvcounts(iope+1), mpi_real4, vg3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + vg = reshape(vg3d_0(:,:,krev),(/nlons*nlats/)) + 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 (pst_ind > 0) then + krev = nlevs-k+1 + ug = ug*(pressi(:,krev)-pressi(:,krev+1)) + vg = vg*(pressi(:,krev)-pressi(:,krev+1)) + call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt + call sptez_s(divspec,vmassdiv(:,krev),1) ! divspec to divgrd + endif + enddo + end if + call read_vardata(dset,'tmp', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading tmp' + call stop2(24) + endif + call read_vardata(dset,'spfh', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading spfh' + call stop2(25) + endif + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + call mpi_gatherv(vg3d, recvcounts(iope+1), mpi_real4, vg3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + vg = reshape(vg3d_0(:,:,krev),(/nlons*nlats/)) + if (tsen_ind > 0) call copytogrdin(ug,grdin(:,levels(tsen_ind-1)+k,nb,ne)) + call copytogrdin(vg, q(:,k)) + ug = ug * ( 1.0 + fv*vg ) ! convert T to Tv + call copytogrdin(ug,tv(:,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) + end do + end if + + if (oz_ind > 0) then + call read_vardata(dset, 'o3mr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading o3mr' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(oz_ind-1)+k,nb,ne)) + end do + end if + endif + if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then + call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading clwmr' + call stop2(27) + endif + if (imp_physics == 11) then + call read_vardata(dset, 'icmr', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading icmr' + call stop2(28) + endif + ug3d = ug3d + vg3d + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,cw(:,k)) + if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k) + end do + end if + endif + deallocate(ug3d,vg3d) + + ! surface pressure + if (ps_ind > 0 .and. iope==0) then + call copytogrdin(psg,grdin(:,levels(n3d) + ps_ind,nb,ne)) + endif + + ! surface pressure tendency + if (pst_ind > 0 .and. iope==0) then + pstend = sum(vmassdiv,2) + if (nanal .eq. 1 .and. iope==0) & + print *,nanal,'min/max first-guess ps tend',minval(pstend),maxval(pstend) + call copytogrdin(pstend,grdin(:,levels(n3d) + pst_ind,nb,ne)) + endif + + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ! layer pressure from phillips vertical interolation + ug(:) = ((pressi(:,k)**kap1-pressi(:,k+1)**kap1)/& + (kap1*(pressi(:,k)-pressi(:,k+1))))**kapr + 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(q,qsat(:,:,nb,ne),pslg,tv,ice,npts,nlevs) + else + qsat(:,:,nb,ne) = 1._r_double + end if + end if + + ! cloud derivatives + if (.not. use_full_hydro .and. iope==0) 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 .and. iope==0) then + grdin(:,levels(n3d)+sst_ind, nb,ne) = zero + endif + + ! bring all the subdomains back to the main PE + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + + deallocate(pressi,pslg) + deallocate(psg) + if (pst_ind > 0) deallocate(vmassdiv,pstend) + call close_dataset(dset) + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + + + end do backgroundloop ! loop over backgrounds to read in + + ! remove the sub communicators + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + call mpi_comm_free(iocomms(mem_pe(nproc)), iret) + call mpi_barrier(mpi_comm_world, iret) + + + 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_pnc + + + subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & + fileprefixes,filesfcprefixes,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_charkind,& nemsio_readrecv,nemsio_init,nemsio_setheadvar,nemsio_writerecv + use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + quantize_data,read_attribute, close_dataset, get_dim, read_vardata implicit none integer, intent(in) :: nanal1,nanal2 @@ -69,38 +427,44 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f integer, dimension(0:n3d), intent(in) :: levels integer, intent(in) :: ndim, ntimes character(len=120), dimension(7), intent(in) :: fileprefixes + character(len=120), dimension(7), intent(in) :: filesfcprefixes 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 character(len=500) :: filename + character(len=500) :: filenamesfc 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_single), allocatable, dimension(:,:) :: pressi,pslg,values_2d 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_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(r_single),allocatable,dimension(:,:,:) :: nems_vcoord, ug3d,vg3d real(nemsio_realkind), dimension(nlons*nlats) :: nems_wrk,nems_wrk2 type(sigio_head) :: sighead type(sigio_data) :: sigdata type(nemsio_gfile) :: gfile + type(Dataset) :: dset + type(Dimension) :: londim,latdim,levdim + type(nemsio_gfile) :: gfilesfc 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) :: 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,iunitsig,iret,nb,i,idvc,nlonsin,nlatsin,nlevsin,ne,nanal + integer(i_kind) :: nlonsin_sfc,nlatsin_sfc logical ice - logical use_full_hydro + logical use_full_hydro - use_full_hydro = .false. + use_full_hydro = .false. ne = 0 ensmemloop: do nanal=nanal1,nanal2 @@ -114,6 +478,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f endif iunitsig = 77 filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) + filenamesfc = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal) if (use_gfs_nemsio) then call nemsio_init(iret=iret) if(iret/=0) then @@ -133,6 +498,26 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f print *,'got',nlonsin,nlatsin,nlevsin call stop2(23) end if + + if (cnvw_option) then + call nemsio_open(gfilesfc,filenamesfc,'READ',iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: gfs model: problem with sfc nemsio_open, iret=',iret + else + call nemsio_getfilehead(gfilesfc,iret=iret, dimx=nlonsin_sfc, dimy=nlatsin_sfc) + if (nlons /= nlonsin_sfc .or. nlats /= nlatsin_sfc) then + print *,'incorrect dims in nemsio sfc file' + print *,'expected',nlons,nlats + print *,'got',nlonsin_sfc,nlatsin_sfc + end if + endif + endif + else if (use_gfs_ncio) then + dset = open_dataset(filename) + londim = get_dim(dset,'grid_xt'); nlonsin = londim%len + latdim = get_dim(dset,'grid_yt'); nlatsin = latdim%len + levdim = get_dim(dset,'pfull'); nlevsin = levdim%len + idvc=2 else call sigio_srohdc(iunitsig,trim(filename), & sighead,sigdata,iret) @@ -146,7 +531,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f kapr = cp/rd kap1 = kap+one - u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + u_ind = getindex(vars3d, 'u') !< indices in the state or control 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) @@ -223,6 +608,25 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f if (nanal .eq. 1) print *,'nemsio, min/max pressi',k,minval(pressi(:,k)),maxval(pressi(:,k)) enddo deallocate(ak,bk) + else if (use_gfs_ncio) then + call read_vardata(dset, 'pressfc', values_2d,errcode=iret) + if (iret /= 0) then + print *,'error reading ps' + call stop2(31) + endif + psg = 0.01_r_kind*reshape(values_2d,(/nlons*nlats/)) + call read_attribute(dset, 'ak', ak) + call read_attribute(dset, 'bk', bk) + if (nanal .eq. 1) then + print *,'time level ',nb + print *,'---------------' + endif + ! pressure at interfaces + do k=1,nlevs+1 + pressi(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*psg + if (nanal .eq. 1) print *,'netcdf, min/max pressi',k,minval(pressi(:,k)),maxval(pressi(:,k)) + enddo + deallocate(ak,bk,values_2d) else vrtspec = sigdata%ps call sptez_s(vrtspec,psg,1) @@ -236,11 +640,11 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f 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) + 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) + call stop2(32) end if !==> pressure at interfaces. if (nanal .eq. 1) then @@ -311,7 +715,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f ug = nems_wrk2 call copytogrdin(ug,grdin(:,levels(oz_ind-1)+k,nb,ne)) endif - if (.not. use_full_hydro) then + 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 @@ -327,6 +731,15 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f nems_wrk2 = nems_wrk2 + nems_wrk endif endif + if (cnvw_option) then + call nemsio_readrecv(gfilesfc,'cnvcldwat','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(cnvw), iret=',iret + call stop2(23) + else + nems_wrk2 = nems_wrk2 + nems_wrk + end if + end if if (cliptracers) where (nems_wrk2 < clip) nems_wrk2 = clip ug = nems_wrk2 call copytogrdin(ug,cw(:,k)) @@ -390,10 +803,89 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f endif endif ! use_full_hydro enddo + else if (use_gfs_ncio) then + call read_vardata(dset, 'ugrd', ug3d,errcode=iret) + if (iret /= 0) then + print *,'error reading ugrd' + call stop2(22) + endif + call read_vardata(dset, 'vgrd', vg3d,errcode=iret) + if (iret /= 0) then + print *,'error reading vgrd' + call stop2(23) + endif + do k=1,nlevs + ug = reshape(ug3d(:,:,nlevs-k+1),(/nlons*nlats/)) + vg = reshape(vg3d(:,:,nlevs-k+1),(/nlons*nlats/)) + 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 (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 + call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd + endif + enddo + call read_vardata(dset,'tmp', ug3d,errcode=iret) + if (iret /= 0) then + print *,'error reading tmp' + call stop2(24) + endif + call read_vardata(dset,'spfh', vg3d,errcode=iret) + if (iret /= 0) then + print *,'error reading spfh' + call stop2(25) + endif + do k=1,nlevs + ug = reshape(ug3d(:,:,nlevs-k+1),(/nlons*nlats/)) + vg = reshape(vg3d(:,:,nlevs-k+1),(/nlons*nlats/)) + if (tsen_ind > 0) call copytogrdin(ug,grdin(:,levels(tsen_ind-1)+k,nb,ne)) + call copytogrdin(vg, q(:,k)) + ug = ug * ( 1.0 + fv*vg ) ! convert T to Tv + call copytogrdin(ug,tv(:,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) + enddo + if (oz_ind > 0) then + call read_vardata(dset, 'o3mr', ug3d,errcode=iret) + if (iret /= 0) then + print *,'error reading o3mr' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + do k=1,nlevs + ug = reshape(ug3d(:,:,nlevs-k+1),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(oz_ind-1)+k,nb,ne)) + enddo + endif + if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then + call read_vardata(dset, 'clwmr', ug3d,errcode=iret) + if (iret /= 0) then + print *,'error reading clwmr' + call stop2(27) + endif + if (imp_physics == 11) then + call read_vardata(dset, 'icmr', vg3d,errcode=iret) + if (iret /= 0) then + print *,'error reading icmr' + call stop2(28) + endif + ug3d = ug3d + vg3d + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + do k=1,nlevs + ug = reshape(ug3d(:,:,nlevs-k+1),(/nlons*nlats/)) + call copytogrdin(ug,cw(:,k)) + if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k) + enddo + endif + deallocate(ug3d,vg3d) else !$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 (u_ind > 0) then @@ -421,7 +913,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f 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 @@ -474,14 +966,14 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f end if ! cloud derivatives - if (.not. use_full_hydro) then + 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 + 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 @@ -490,7 +982,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f enddo enddo endif - endif + endif if (sst_ind > 0) then grdin(:,levels(n3d)+sst_ind, nb,ne) = zero @@ -500,12 +992,14 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f deallocate(psg) if (pst_ind > 0) deallocate(vmassdiv,pstend) if (use_gfs_nemsio) call nemsio_close(gfile,iret=iret) + if (use_gfs_ncio) call close_dataset(dset) + if (use_gfs_nemsio) call nemsio_close(gfilesfc,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) @@ -524,72 +1018,106 @@ end subroutine copytogrdin end subroutine readgriddata - 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_charkind,& - nemsio_getheadvar,nemsio_realkind,nemsio_getfilehead,& - nemsio_readrecv,nemsio_init,nemsio_setheadvar,nemsio_writerecv - use constants, only: grav - use params, only: nbackgrounds,anlfileprefixes,fgfileprefixes,reducedgrid + subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use netcdf + use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + read_attribute, close_dataset, get_dim, read_vardata,& + create_dataset, get_idate_from_time_units, & + get_time_units_from_idate, write_vardata, & + write_attribute, quantize_data, has_var, has_attr + use constants, only: grav, zero + use params, only: nbackgrounds,anlfileprefixes,fgfileprefixes,reducedgrid,& + nccompress 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 + real(r_single), dimension(npts,ndim,nbackgrounds,1), intent(inout) :: grdin logical, intent(in) :: no_inflate_flag - logical:: use_full_hydro + 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(:,:) :: ugtmp,vgtmp,ugtmp2,vgtmp2 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), allocatable, dimension(:) :: delzb,work,values_1d real(r_kind), dimension(ndimspec) :: vrtspec,divspec - integer iadate(4),idate(4),nfhour,idat(7),iret,nrecs,jdate(7) - integer:: nfminute, nfsecondn, nfsecondd + real(r_single), allocatable, dimension(:,:,:) :: & + ug3d,vg3d,values_3d,tmp_anal,tv_anal,tv_bg + real(r_single), allocatable, dimension(:,:) :: values_2d + integer iadate(4),idate(4),nfhour,idat(7),iret,jdat(6) integer,dimension(8):: ida,jda real(r_double),dimension(5):: fha real(r_kind) fhour - type(sigio_head) sighead - type(sigio_data) sigdata_inc + type(Dataset) :: dsfg, dsanl character(len=3) charnanal - character(nemsio_charkind),allocatable:: recname(:) - character(nemsio_charkind) :: field - logical :: hasfield + character(len=nf90_max_name) :: time_units real(r_kind) kap,kapr,kap1,clip - real(nemsio_realkind), dimension(nlons*nlats) :: nems_wrk,nems_wrk2 + real(r_single) compress_err real(r_kind), dimension(nlevs+1) :: ak,bk - real(nemsio_realkind), dimension(nlevs+1,3,2) :: nems_vcoord - integer(nemsio_intkind) :: nems_idvc - type(sigio_data) sigdata - type(nemsio_gfile) :: gfilein,gfileout 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 :: ps_ind, pst_ind, nbits + integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind - integer k,nt,ierr,iunitsig,nb,i,ne,nanal + integer k,nt,iunitsig,nb,i,ne,nanal,imem + + integer(i_kind), allocatable, dimension(:) :: mem_pe, lev_pe1, lev_pe2, iocomms + integer(i_kind) :: iope, ionumproc, iolevs, krev, ki + integer(i_kind) :: ncstart(4), nccount(4) + logical :: nocompress - use_full_hydro = .false. + nocompress = .true. + + if (nccompress) nocompress = .false. + + 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 + ! figure out what member to write and do MPI sub-communicator things + allocate(mem_pe(0:numproc-1)) + allocate(iocomms(nanals)) + imem = 1 + do i=0,numproc-1 + mem_pe(i) = imem + imem = imem + 1 + if (imem > nanals) imem = 1 + end do + nanal = mem_pe(nproc) + + call mpi_comm_split(mpi_comm_world, mem_pe(nproc), nproc, iocomms(mem_pe(nproc)), iret) + call mpi_comm_rank(iocomms(mem_pe(nproc)), iope, iret) + call mpi_comm_size(iocomms(mem_pe(nproc)), ionumproc, iret) + + ! figure out what levels to write on this sub-communicator's PE + allocate(lev_pe1(0:ionumproc-1)) + allocate(lev_pe2(0:ionumproc-1)) + iolevs = nlevs/ionumproc + do i=0,ionumproc-1 + lev_pe1(i) = (iope * iolevs) + 1 + lev_pe2(i) = ((iope + 1) * iolevs) + if (i == ionumproc-1) lev_pe2(i) = lev_pe2(i) + modulo(nlevs, ionumproc) + end do + ncstart = (/1, 1, lev_pe1(iope),1/) + nccount = (/nlons, nlats, lev_pe2(iope) - lev_pe1(iope)+1,1/) + + ! need to distribute grdin to all PEs in this subcommunicator + ! bring all the subdomains back to the main PE + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + call mpi_bcast(grdin,npts*ndim*nbackgrounds, mpi_real4, 0, iocomms(mem_pe(nproc)), iret) + + ! loop through times and do the read + ne = 1 backgroundloop: do nb=1,nbackgrounds + write(charnanal,'(i3.3)') nanal if(no_inflate_flag) then filenameout = trim(adjustl(datapath))//trim(adjustl(anlfileprefixes(nb)))//"nimem"//charnanal @@ -597,73 +1125,42 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n filenameout = trim(adjustl(datapath))//trim(adjustl(anlfileprefixes(nb)))//"mem"//charnanal end if filenamein = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nb)))//"mem"//charnanal - ! for nemsio, analysis file must be copied from first guess at scripting - ! 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 - call stop2(23) - end if - call nemsio_open(gfilein,filenamein,'READ',iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_open, iret=',iret - call stop2(23) - endif - call nemsio_getfilehead(gfilein,iret=iret,idate=idat,nfhour=nfhour,& - 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) - - 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) - else if (nems_idvc == 2 .or. nems_idvc == 3) then ! hybrid coordinate - bk = nems_vcoord(1:nlevs+1,2,1) - ak = 0.01_r_kind*nems_vcoord(1:nlevs+1,1,1) ! convert to mb - else - print *,'unknown vertical coordinate type',nems_idvc - call stop2(23) - end if - else - ! 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 + clip = tiny(vg(1)) + dsfg = open_dataset(filenamein, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) + jdat = get_idate_from_time_units(dsfg) + idat(4) = jdat(1) ! yr + idat(2) = jdat(2) ! mon + idat(3) = jdat(3) ! day + idat(1) = jdat(4) ! hr + call read_vardata(dsfg,'time',values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading time' + call stop2(29) + endif + nfhour = int(values_1d(1)) + call read_attribute(dsfg, 'ak', values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading ak' + call stop2(29) endif + do k=1,nlevs+1 + ak(nlevs-k+2) = 0.01_r_kind*values_1d(k) + enddo + call read_attribute(dsfg, 'bk', values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading bk' + call stop2(29) + endif + do k=1,nlevs+1 + bk(nlevs-k+2) = values_1d(k) + enddo - u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + u_ind = getindex(vars3d, 'u') !< indices in the control 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) + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) oz_ind = getindex(vars3d, 'oz') ! Oz (3D) cw_ind = getindex(vars3d, 'cw') ! CW (3D) ql_ind = getindex(vars3d, 'ql') ! QL (3D) @@ -671,20 +1168,11 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n 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)) @@ -694,21 +1182,18 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n allocate(pstendfg(nlons*nlats)) allocate(pstend1(nlons*nlats)) allocate(pstend2(nlons*nlats),vmass(nlons*nlats)) + allocate(ugtmp(nlons*nlats,nlevs),vgtmp(nlons*nlats,nlevs)) + allocate(ugtmp2(nlons*nlats,nlevs),vgtmp2(nlons*nlats,nlevs)) endif -! 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 - idate = sighead%idate - fhour = sighead%fhour - else - idate(3)=idat(3) - idate(2)=idat(2) - idate(4)=idat(1) - idate(1)=idat(4) - fhour = nfhour - endif + if (imp_physics == 11 .and. (.not. use_full_hydro) ) allocate(work(nlons*nlats)) + + idate(3)=idat(3) !day + idate(2)=idat(2) !mon + idate(4)=idat(4) !yr + idate(1)=idat(1) !hr + fhour = nfhour + fha=zero; ida=0; jda=0 fha(2)=fhour ! relative time interval in hours ida(1)=idate(4) ! year @@ -739,183 +1224,110 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n print *,'iadate = ',iadate end if - if (.not. use_gfs_nemsio) then ! spectral sigio - sighead%idate = iadate - sighead%fhour = zero - ! ensemble info - ! http://www.emc.ncep.noaa.gov/gmb/ens/info/ens_grib.html#gribex - sighead%iens(1) = 3 ! pos pert - sighead%iens(2) = nanal ! ensemble member number - sighead%icen2 = 2 ! sub-center, must be 2 or ens info not used - if (.not. isinitialized) call init_spec_vars(nlons,nlats,sighead%jcap,4) - ! allocate new sigdata structure for increments. - call sigio_aldata(sighead,sigdata_inc,ierr) - ! convert to increment to spectral coefficients. -!$omp parallel do private(k,nt,ug,vg,divspec,vrtspec) shared(grdin,sigdata_inc) - do k=1,nlevs - 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 - - 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 - - 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. - 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 - psg = vg - vg = log(vg/10._r_kind) ! convert back to centibars. - call sptez_s(divspec,vg,-1) - sigdata%ps = divspec - - else ! nemsio - gfileout = gfilein - - nfhour = 0 ! new forecast hour, zero at analysis time - nfminute = 0 - nfsecondn = 0 - nfsecondd = 100 ! default for denominator - - !iadate = hh/mm/dd/yyyy - !jdate = yyyy/mm/dd/hh/min/secn/secd - - jdate(1) = iadate(4) ! analysis year - jdate(2) = iadate(2) ! analysis month - jdate(3) = iadate(3) ! analysis day - jdate(4) = iadate(1) ! analysis hour - jdate(5) = nfminute ! analysis minute - jdate(6) = nfsecondn ! analysis scaled seconds - jdate(7) = nfsecondd ! analysis seconds multiplier - - call nemsio_open(gfileout,filenameout,'WRITE',iret=iret,& - 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) - - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_open for output, iret=',iret - call stop2(23) - end if - -! read/write orographay - call nemsio_readrecv(gfilein,'hgt','sfc',1,nems_wrk,iret=iret) - call nemsio_writerecv(gfileout,'hgt','sfc',1,nems_wrk,iret=iret) - - 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. - 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) - 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) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(dpres), iret=',iret - call stop2(23) - endif - nems_wrk = nems_wrk + 100.*psg - call nemsio_writerecv(gfileout,'dpres','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(dpres), iret=',iret - call stop2(23) - endif - enddo + dsanl = create_dataset(filenameout, dsfg, copy_vardata=.true., & + nocompress=nocompress, paropen=.true., mpicomm=iocomms(mem_pe(nproc)), errcode=iret) + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + if (iret /= 0) then + print *,'error creating netcdf file' + call stop2(29) + endif + deallocate(values_1d) + allocate(values_1d(1)) + values_1d(1)=zero + call write_vardata(dsanl,'time',values_1d,errcode=iret) + if (iret /= 0) then + print *,'error writing time' + call stop2(29) + endif + jdat(1) = iadate(4) + jdat(2) = iadate(2) + jdat(3) = iadate(3) + jdat(4) = iadate(1) + jdat(5) = jda(6); jdat(6) = jda(7) + time_units = get_time_units_from_idate(jdat) + call write_attribute(dsanl,'units',time_units,'time',errcode=iret) + if (iret /= 0) then + print *,'error writing time units attribute' + call stop2(29) + endif + call read_vardata(dsfg,'pressfc',values_2d,errcode=iret) + if (iret /= 0) then + print *,'error reading pressfc' + call stop2(29) + endif + psfg = 0.01*reshape(values_2d,(/nlons*nlats/)) + ug = 0_r_kind + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),ug) + endif + ! add increment to background. + psg = psfg + ug ! analysis pressure in mb. + values_2d = 100.*reshape(psg,(/nlons,nlats/)) + call write_vardata(dsanl,'pressfc',values_2d, ncstart=(/1,1,1/), nccount=(/nlons,nlats,1/), errcode=iret) + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + if (iret /= 0) then + print *,'error writing pressfc' + call stop2(29) + endif + if (has_var(dsfg,'dpres')) then + call read_vardata(dsfg,'dpres',ug3d, ncstart=ncstart, nccount=nccount) + allocate(vg3d(nlons,nlats,nccount(3))) + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + vg = ug*(bk(krev)-bk(krev+1)) ! ug is ps increment + vg3d(:,:,ki) = ug3d(:,:,ki) +& + 100_r_kind*reshape(vg,(/nlons,nlats/)) + end do + if (has_attr(dsfg, 'nbits', 'dpres') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'dpres') + ug3d = vg3d + call quantize_data(ug3d, vg3d, nbits, compress_err) + ! below is not technically correct but I'm not worried about + ! the exact value of this attribute right now + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'dpres',errcode=iret) + if (iret /= 0) then + print *,'error writing dpres attribute' + call stop2(29) + end if 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 - call stop2(23) + call write_vardata(dsanl,'dpres',vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error writing dpres' + call stop2(29) endif - endif - + end if if (pst_ind > 0) then !==> first guess pressure at interfaces. do k=1,nlevs+1 - pressi(:,k)=ak(k)+bk(k)*psfg + pressi(:,k)=ak(k)+bk(k)*psfg ! psfg in mb, ak has been scaled by 0.01 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 + pressi(:,k)=ak(k)+bk(k)*psg ! psg in mb, ak has been scaled by 0.01 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 + end do + ! have to read in the full arrays here because of vertical integral... + call read_vardata(dsfg, 'ugrd', ug3d, errcode=iret) + if (iret /= 0) then + print *,'error reading ugrd' + call stop2(29) + endif + call read_vardata(dsfg, 'vgrd', vg3d, errcode=iret) + if (iret /= 0) then + print *,'error reading vgrd' + call stop2(29) + endif do k=1,nlevs -! re-calculate vertical integral of mass flux div for first-guess - if (use_gfs_nemsio) then - call nemsio_readrecv(gfilein,'ugrd','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(ugrd), iret=',iret - call stop2(23) - endif - ug = nems_wrk - call nemsio_readrecv(gfilein,'vgrd','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(vgrd), iret=',iret - call stop2(23) - endif - vg = nems_wrk - else - divspec = sigdata%d(:,k); vrtspec = sigdata%z(:,k) - call sptezv_s(divspec,vrtspec,ug,vg,1) - endif + krev = nlevs-k+1 + ug = reshape(ug3d(:,:,krev),(/nlons*nlats/)) + vg = reshape(vg3d(:,:,krev),(/nlons*nlats/)) ug = ug*dpfg(:,k) vg = vg*dpfg(:,k) call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt @@ -926,7 +1338,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n call copyfromgrdin(grdin(:,levels(n3d) + pst_ind,nb,ne),pstend2) pstendfg = sum(vmassdiv,2) vmassdivinc = vmassdiv - if (nanal .eq. 1) then + if (nanal .eq. 1 .and. iope==0) then print *,'time level ',nb print *,'--------------------' print *,nanal,'min/max pstendfg',minval(pstendfg),maxval(pstendfg) @@ -934,177 +1346,1193 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n endif pstend2 = pstend2 + pstendfg ! add to background ps tend + ugtmp(:,:) = zero + ugtmp2(:,:) = zero + vgtmp(:,:) = zero + vgtmp2(:,:) = zero endif ! if pst_ind > 0 - if (.not. use_gfs_nemsio) then - ! add increment to first guess in spectral space. -!$omp parallel do private(k,nt,ug,vg,vrtspec,divspec) shared(sigdata,sigdata_inc,vmassdiv,dpanl) + + ! now do parallel read and apply increments + call read_vardata(dsfg, 'ugrd', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading ugrd' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug = 0_r_kind + if (u_ind > 0) then + call copyfromgrdin(grdin(:,levels(u_ind-1) + krev,nb,ne),ug) + endif + values_2d = reshape(ug,(/nlons,nlats/)) + ug3d(:,:,ki) = ug3d(:,:,ki) + values_2d + if (pst_ind > 0) then + ugtmp2(:,krev) = reshape(ug3d(:,:,k),(/nlons*nlats/)) + endif + enddo + if (has_attr(dsfg, 'nbits', 'ugrd') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'ugrd') + if (.not. allocated(vg3d)) allocate(vg3d(nlons,nlats,nccount(3))) + vg3d = ug3d + call quantize_data(vg3d, ug3d, nbits, compress_err) + ! same as before, below is not ideal + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'ugrd',errcode=iret) + if (iret /= 0) then + print *,'error writing ugrd attribute' + call stop2(29) + end if + endif + call write_vardata(dsanl, 'ugrd', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + call read_vardata(dsfg, 'vgrd', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading vgrd' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + vg = 0_r_kind + if (v_ind > 0) then + call copyfromgrdin(grdin(:,levels(v_ind-1) + krev,nb,ne),vg) + endif + values_2d = reshape(vg,(/nlons,nlats/)) + vg3d(:,:,ki) = vg3d(:,:,ki) + values_2d + if (pst_ind > 0) then + vgtmp2(:,krev) = reshape(vg3d(:,:,k),(/nlons*nlats/)) + endif + enddo + if (has_attr(dsfg, 'nbits', 'vgrd') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'vgrd') + if (.not. allocated(ug3d)) allocate(ug3d(nlons,nlats,nccount(3))) + ug3d = vg3d + call quantize_data(ug3d, vg3d, nbits, compress_err) + ! same as before, below is not ideal + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'vgrd',errcode=iret) + if (iret /= 0) then + print *,'error writing ugrd attribute' + call stop2(29) + end if + endif + call write_vardata(dsanl, 'vgrd', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (pst_ind > 0) then + do k=1,nlevs + call mpi_allreduce(ugtmp2(:,k), ugtmp(:,k), nlons*nlats, mpi_rtype, & + mpi_sum, iocomms(mem_pe(nproc)),iret) + call mpi_allreduce(vgtmp2(:,k), vgtmp(:,k), nlons*nlats, mpi_rtype, & + mpi_sum, iocomms(mem_pe(nproc)),iret) + end do + end if + if (pst_ind > 0) then do k=1,nlevs + ug = ugtmp(:,k)*dpanl(:,k) + vg = vgtmp(:,k)*dpanl(:,k) + call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt + call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd + enddo + end if + ! read sensible temperature and specific humidity + call read_vardata(dsfg, 'tmp', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading tmp' + call stop2(29) + endif + call read_vardata(dsfg, 'spfh', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading spfh' + call stop2(29) + endif + allocate(tv_bg(nlons,nlats,nccount(3)),tv_anal(nlons,nlats,nccount(3))) + tv_bg = ug3d * ( 1.0 + fv*vg3d ) !Convert T to Tv + call read_vardata(dsfg,'pressfc',values_2d,errcode=iret) + if (iret /= 0) then + print *,'error reading pressfc' + call stop2(29) + endif + if (allocated(values_1d)) deallocate(values_1d) + allocate(values_1d(nlons*nlats)) + values_1d = reshape(values_2d,(/nlons*nlats/)) + ! add Tv,q increment to background + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug = 0_r_kind + if (tv_ind > 0) then + call copyfromgrdin(grdin(:,levels(tv_ind-1)+krev,nb,ne),ug) + endif + vg = 0_r_kind + if (q_ind > 0) then + call copyfromgrdin(grdin(:,levels(q_ind-1)+krev,nb,ne),vg) + endif + values_2d = reshape(ug,(/nlons,nlats/)) + tv_anal(:,:,ki) = tv_bg(:,:,ki) + values_2d + values_2d = reshape(vg,(/nlons,nlats/)) + vg3d(:,:,ki) = vg3d(:,:,ki) + values_2d + enddo + ! now tv_anal is analysis Tv, vg3d is analysis spfh + if (cliptracers) where (vg3d < clip) vg3d = clip -! add increments in spectral space - 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,sighead%ntrac - sigdata%q(:,k,nt) = sigdata%q(:,k,nt) + sigdata_inc%q(:,k,nt) - enddo + ! write analysis T + allocate(values_3d(nlons,nlats,nccount(3))) + allocate(tmp_anal(nlons,nlats,nccount(3))) + tmp_anal = tv_anal/(1. + fv*vg3d) ! convert Tv back to T, save q as vg3d + values_3d = tmp_anal + if (has_attr(dsfg, 'nbits', 'tmp') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'tmp') + call quantize_data(tmp_anal, values_3d, nbits, compress_err) + ! yet again, below not technically correct... + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'tmp',errcode=iret) + if (iret /= 0) then + print *,'error writing tmp attribute' + call stop2(29) + end if + endif + call write_vardata(dsanl,'tmp',values_3d,ncstart=ncstart,nccount=nccount,errcode=iret) ! write T + if (iret /= 0) then + print *,'error writing tmp' + call stop2(29) + endif + call mpi_barrier(iocomms(mem_pe(nproc)), iret) - 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) - ug = ug*dpanl(:,k) - vg = vg*dpanl(:,k) - call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt - call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd + ! write analysis delz + if (has_var(dsfg,'delz')) then + allocate(delzb(nlons*nlats)) + call read_vardata(dsfg, 'delz', values_3d, ncstart=ncstart, nccount=nccount, errcode=iret) + vg = 0_r_kind + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),vg) + endif + vg = values_1d + (vg*100_r_kind) ! analysis ps (values_1d is background ps) + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug=(rd/grav)*reshape(tv_anal(:,:,ki),(/nlons*nlats/)) + ! ps in Pa here, need to multiply ak by 100. + ug=ug*log((100_r_kind*ak(krev)+bk(krev)*vg)/(100_r_kind*ak(krev+1)+bk(krev+1)*vg)) + ! ug is hydrostatic analysis delz inferred from analysis ps,Tv + ! delzb is hydrostatic background delz inferred from background ps,Tv + delzb=(rd/grav)*reshape(tv_bg(:,:,ki),(/nlons*nlats/)) + delzb=delzb*log((100_r_kind*ak(krev)+bk(krev)*values_1d)/(100_r_kind*ak(krev+1)+bk(krev+1)*values_1d)) + ug3d(:,:,ki)=values_3d(:,:,ki) + reshape(delzb-ug,(/nlons,nlats/)) + end do + if (has_attr(dsfg, 'nbits', 'delz') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'delz') + values_3d = ug3d + call quantize_data(values_3d, ug3d, nbits, compress_err) + ! again, only the first PE's error is being accounted for in this attribute + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'delz',errcode=iret) + if (iret /= 0) then + print *,'error writing delz attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'delz',ug3d,ncstart=ncstart,nccount=nccount,errcode=iret) ! write delz + if (iret /= 0) then + print *,'error writing delz' + call stop2(29) + endif + endif + deallocate(tv_anal,tv_bg) ! keep tmp_anal + + ! write analysis q (still stored in vg3d) + if (has_attr(dsfg, 'nbits', 'spfh') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'spfh') + values_3d = vg3d + call quantize_data(values_3d, vg3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'spfh',errcode=iret) + if (iret /= 0) then + print *,'error writing spfh attribute' + call stop2(29) + end if + endif + call write_vardata(dsanl,'spfh',vg3d,ncstart=ncstart,nccount=nccount,errcode=iret) ! write q + if (iret /= 0) then + print *,'error writing spfh' + call stop2(29) + endif + ! write clwmr, icmr + call read_vardata(dsfg,'clwmr',ug3d,ncstart=ncstart,nccount=nccount,errcode=iret) + if (iret /= 0) then + print *,'error reading clwmr' + call stop2(29) + endif + if (imp_physics == 11) then + call read_vardata(dsfg,'icmr',vg3d,ncstart=ncstart,nccount=nccount,errcode=iret) + if (iret /= 0) then + print *,'error reading icmr' + call stop2(29) + endif + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug = 0_r_kind + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) + endif + if (imp_physics == 11) then + work = -r0_05 * (reshape(tmp_anal(:,:,ki),(/nlons*nlats/)) - t0c) + do i=1,nlons*nlats + work(i) = max(zero,work(i)) + work(i) = min(one,work(i)) + enddo + vg = ug * work ! cloud ice + ug = ug * (one - work) ! cloud water + vg3d(:,:,ki) = vg3d(:,:,ki) + reshape(vg,(/nlons,nlats/)) + endif + ug3d(:,:,ki) = ug3d(:,:,ki) + reshape(ug,(/nlons,nlats/)) + enddo + deallocate(tmp_anal) + if (cw_ind > 0) then + if (has_attr(dsfg, 'nbits', 'clwmr') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'clwmr') + values_3d = ug3d + call quantize_data(values_3d, ug3d, nbits, compress_err) + if (cliptracers) where (ug3d < clip) ug3d = clip + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'clwmr',errcode=iret) + if (iret /= 0) then + print *,'error writing clwmr attribute' + call stop2(29) + end if + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + endif + call write_vardata(dsanl,'clwmr',ug3d,ncstart=ncstart,nccount=nccount,errcode=iret) + if (iret /= 0) then + print *,'error writing clwmr' + call stop2(29) + endif + if (imp_physics == 11) then + if (cw_ind > 0) then + if (has_attr(dsfg, 'nbits', 'clwmr') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'clwmr') + values_3d = vg3d + call quantize_data(values_3d, vg3d, nbits, compress_err) + if (cliptracers) where (vg3d < clip) vg3d = clip + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'icmr',errcode=iret) + if (iret /= 0) then + print *,'error writing icmr attribute' + call stop2(29) + end if endif + if (cliptracers) where (vg3d < clip) vg3d = clip + endif + call write_vardata(dsanl,'icmr',vg3d,ncstart=ncstart,nccount=nccount,errcode=iret) ! write icmr + if (iret /= 0) then + print *,'error writing icmr' + call stop2(29) + endif + endif - enddo -!$omp end parallel do + ! write analysis ozone + call read_vardata(dsfg,'o3mr',vg3d,ncstart=ncstart,nccount=nccount,errcode=iret) + if (iret /= 0) then + print *,'error reading o3mr' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug = 0_r_kind + if (oz_ind > 0) then + call copyfromgrdin(grdin(:,levels(oz_ind-1)+krev,nb,ne),ug) + endif + vg3d(:,:,ki) = vg3d(:,:,ki) + reshape(ug,(/nlons,nlats/)) + enddo + if (oz_ind > 0) then + if (has_attr(dsfg, 'nbits', 'o3mr') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'o3mr') + values_3d = vg3d + call quantize_data(values_3d, vg3d, nbits, compress_err) + if (cliptracers) where (vg3d < clip) vg3d = clip + ! again, below is lazy/not ideal/bad + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'o3mr',errcode=iret) + if (iret /= 0) then + print *,'error writing o3mr attribute' + call stop2(29) + end if + endif + if (cliptracers) where (vg3d < clip) vg3d = clip + endif + call write_vardata(dsanl,'o3mr',vg3d,ncstart=ncstart,nccount=nccount,errcode=iret) ! write o3mr + if (iret /= 0) then + print *,'error writing o3mr' + call stop2(29) + end if - ! don't need sigdata_inc anymore. - call sigio_axdata(sigdata_inc,ierr) - else - if (pst_ind > 0) then - allocate(ugtmp(nlons*nlats,nlevs),vgtmp(nlons*nlats,nlevs)) + if (allocated(delzb)) deallocate(delzb) + if (imp_physics == 11 .and. (.not. use_full_hydro)) deallocate(work) + + if (pst_ind > 0) then + + vmassdivinc = vmassdiv - vmassdivinc ! analyis - first guess VIMFD + ! (VIMFD = vertically integrated mass flux divergence) + pstend1 = sum(vmassdiv,2) + if (nanal .eq. 1 .and. iope==0) then + print *,nanal,'min/max analysis ps tend',minval(pstend1),maxval(pstend1) + print *,nanal,'min/max analyzed ps tend',minval(pstend2),maxval(pstend2) endif - field = 'delz'; hasfield = checkfield(field,recname,nrecs) - if (hasfield) allocate(delzb(nlons*nlats)) - ! update u,v,Tv,q,oz,clwmr + ! vmass is vertical integral of dp**2 do k=1,nlevs - call nemsio_readrecv(gfilein,'ugrd','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(ugrd), iret=',iret - call stop2(23) - endif - 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 (pst_ind < 0) then - nems_wrk = ug - call nemsio_writerecv(gfileout,'ugrd','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(ugrd), iret=',iret - call stop2(23) - endif - else - ugtmp(:,k) = ug - endif - - call nemsio_readrecv(gfilein,'vgrd','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(vgrd), iret=',iret - call stop2(23) - endif - 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 (pst_ind < 0) then - nems_wrk = vg - call nemsio_writerecv(gfileout,'vgrd','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(vgrd), iret=',iret - call stop2(23) - endif - else - vgtmp(:,k) = vg + ! case 2 (4.3.1.2) in GEOS DAS document. + ! (adjustment proportional to mass in layer) + vmass = vmass + dpanl(:,k)**2 + ! case 3 (4.3.1.3) in GEOS DAS document. + ! (adjustment propotional to mass-flux div increment) + !vmass = vmass + vmassdivinc(:,k)**2 + enddo + ! adjust wind field in analysis so pstend is consistent with pstend2 + ! (analyzed pstend) +!$omp parallel do private(k,nt,ug,vg,uginc,vginc,vrtspec,divspec) shared(vmassdiv,vmassdivinc,dpanl) + do k=1,nlevs + ! case 2 + ug = (pstend2 - pstend1)*dpanl(:,k)**2/vmass + ! case 3 + !ug = (pstend2 - pstend1)*vmassdivinc(:,k)**2/vmass + call sptez_s(divspec,ug,-1) ! divgrd to divspec + vrtspec = 0_r_kind + call sptezv_s(divspec,vrtspec,uginc,vginc,1) ! div,vrt to u,v + if (nanal .eq. 1 .and. iope==0) then + print *,k,'min/max u inc (member 1)',& + minval(uginc/dpanl(:,k)),maxval(uginc/dpanl(:,k)) endif + ugtmp(:,k) = (ugtmp(:,k)*dpanl(:,k) + uginc)/dpanl(:,k) + vgtmp(:,k) = (vgtmp(:,k)*dpanl(:,k) + vginc)/dpanl(:,k) + ug = ugtmp(:,k); vg = vgtmp(:,k) + ug = ug*dpanl(:,k); vg = vg*dpanl(:,k) + 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 + ! should be same as analyzed ps tend + psfg = sum(vmassdiv,2) + if (nanal .eq. 1 .and. iope==0) then + print *,nanal,'min/max adjusted ps tend',minval(psfg),maxval(psfg) + print *,nanal,'min/max diff between adjusted and analyzed ps tend',& + minval(pstend2-psfg),maxval(pstend2-psfg) + endif - 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 - call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd - end if + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug3d(:,:,ki) = reshape(ugtmp(:,krev),(/nlons,nlats/)) + vg3d(:,:,ki) = reshape(vgtmp(:,krev),(/nlons,nlats/)) + enddo + if (has_attr(dsfg, 'nbits', 'ugrd') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'ugrd') + values_3d = ug3d + call quantize_data(values_3d, ug3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'ugrd',errcode=iret) + if (iret /= 0) then + print *,'error writing ugrd attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'ugrd',ug3d,ncstart=ncstart,nccount=nccount,errcode=iret) ! write u + if (iret /= 0) then + print *,'error writing ugrd' + call stop2(29) + endif + if (has_attr(dsfg, 'nbits', 'vgrd') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'vgrd') + values_3d = vg3d + call quantize_data(values_3d, vg3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'vgrd',errcode=iret) + if (iret /= 0) then + print *,'error writing vgrd attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'vgrd',vg3d,ncstart=ncstart,nccount=nccount,errcode=iret) ! write v + if (iret /= 0) then + print *,'error writing vgrd' + call stop2(29) + endif + deallocate(ugtmp,vgtmp) + deallocate(ugtmp2,vgtmp2) + endif - call nemsio_readrecv(gfilein,'tmp','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(tmp), iret=',iret - call stop2(23) - endif - call nemsio_readrecv(gfilein,'spfh','mid layer',k,nems_wrk2,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(spfh), iret=',iret - call stop2(23) - endif - nems_wrk = nems_wrk * ( 1.0 + fv*nems_wrk2 ) !Convert T to Tv - 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 - 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 !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)) - work(i) = min(one,work(i)) - enddo - endif - call nemsio_writerecv(gfileout,'tmp','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(tmp), iret=',iret - call stop2(23) - endif - nems_wrk = vg - call nemsio_writerecv(gfileout,'spfh','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(spfh), iret=',iret - call stop2(23) - endif - 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 - ug=ug*log((ak(k)+bk(k)*vg)/(ak(k+1)+bk(k+1)*vg)) - ug=ug-delzb - call nemsio_readrecv(gfilein,'delz','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - 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 - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(delz), iret=',iret - call stop2(23) - endif - endif - - call nemsio_readrecv(gfilein,'o3mr','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(o3mr), iret=',iret - call stop2(23) - endif - 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 (allocated(ug3d)) deallocate(ug3d) + if (allocated(vg3d)) deallocate(vg3d) + if (allocated(values_3d)) deallocate(values_3d) + if (allocated(values_2d)) deallocate(values_2d) + if (allocated(values_1d)) deallocate(values_1d) + + if (pst_ind > 0) then + deallocate(pressi,dpanl,dpfg) + deallocate(pstend1,pstend2,pstendfg,vmass) + deallocate(vmassdiv) + deallocate(vmassdivinc) + endif + call close_dataset(dsfg,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem closing netcdf fg dataset, iret=',iret + call stop2(23) + endif + call close_dataset(dsanl,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem closing netcdf anal dataset, iret=',iret + call stop2(23) + endif + + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + end do backgroundloop ! loop over backgrounds to write out + ! remove the sub communicators + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + call mpi_comm_free(iocomms(mem_pe(nproc)), iret) + call mpi_barrier(mpi_comm_world, iret) + + return + + 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_pnc + + + + subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use netcdf + 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_charkind,& + nemsio_getheadvar,nemsio_realkind,nemsio_getfilehead,& + nemsio_readrecv,nemsio_init,nemsio_setheadvar,nemsio_writerecv + use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + read_attribute, close_dataset, get_dim, read_vardata,& + create_dataset, get_idate_from_time_units, & + get_time_units_from_idate, write_vardata, & + write_attribute, quantize_data, has_var, has_attr + use constants, only: grav + use params, only: nbackgrounds,anlfileprefixes,fgfileprefixes,reducedgrid,& + nccompress + 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 + 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(:) :: pstend1,pstend2,pstendfg,vmass + real(r_kind), dimension(nlons*nlats) :: ug,vg,uginc,vginc,psfg,psg + real(r_kind), allocatable, dimension(:) :: delzb,work,values_1d + real(r_kind), dimension(ndimspec) :: vrtspec,divspec + real(r_single), allocatable, dimension(:,:,:) :: & + ug3d,vg3d,values_3d,tmp_anal,tv_anal,tv_bg + real(r_single), allocatable, dimension(:,:) :: values_2d + integer iadate(4),idate(4),nfhour,idat(7),iret,nrecs,jdate(7),jdat(6) + integer:: nfminute, nfsecondn, nfsecondd + integer,dimension(8):: ida,jda + real(r_double),dimension(5):: fha + real(r_kind) fhour + type(sigio_head) sighead + type(sigio_data) sigdata_inc + type(Dataset) :: dsfg, dsanl + character(len=3) charnanal + character(nemsio_charkind),allocatable:: recname(:) + character(nemsio_charkind) :: field + character(len=nf90_max_name) :: time_units + logical :: hasfield + + real(r_kind) kap,kapr,kap1,clip + real(r_single) compress_err + real(nemsio_realkind), dimension(nlons*nlats) :: nems_wrk,nems_wrk2 + real(r_kind), dimension(nlevs+1) :: ak,bk + real(nemsio_realkind), dimension(nlevs+1,3,2) :: nems_vcoord + integer(nemsio_intkind) :: nems_idvc + type(sigio_data) sigdata + type(nemsio_gfile) :: gfilein,gfileout + + integer :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind + integer :: ps_ind, pst_ind, nbits + integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind + + integer k,nt,ierr,iunitsig,nb,i,ne,nanal + + logical :: nocompress + + nocompress = .true. + if (nccompress) nocompress = .false. + 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 + filenameout = trim(adjustl(datapath))//trim(adjustl(anlfileprefixes(nb)))//"nimem"//charnanal + else + filenameout = trim(adjustl(datapath))//trim(adjustl(anlfileprefixes(nb)))//"mem"//charnanal + end if + filenamein = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nb)))//"mem"//charnanal + + 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 + call stop2(23) + end if + call nemsio_open(gfilein,filenamein,'READ',iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_open, iret=',iret + call stop2(23) + endif + call nemsio_getfilehead(gfilein,iret=iret,idate=idat,nfhour=nfhour,& + 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) + + 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) + else if (nems_idvc == 2 .or. nems_idvc == 3) then ! hybrid coordinate + bk = nems_vcoord(1:nlevs+1,2,1) + ak = 0.01_r_kind*nems_vcoord(1:nlevs+1,1,1) ! convert to mb + else + print *,'unknown vertical coordinate type',nems_idvc + call stop2(23) + end if + else if (use_gfs_ncio) then + clip = tiny(vg(1)) + dsfg = open_dataset(filenamein) + jdat = get_idate_from_time_units(dsfg) + idat(4) = jdat(1) ! yr + idat(2) = jdat(2) ! mon + idat(3) = jdat(3) ! day + idat(1) = jdat(4) ! hr + call read_vardata(dsfg,'time',values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading time' + call stop2(29) + endif + nfhour = int(values_1d(1)) + nems_idvc=2 + call read_attribute(dsfg, 'ak', values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading ak' + call stop2(29) + endif + do k=1,nlevs+1 + ak(nlevs-k+2) = 0.01_r_kind*values_1d(k) + enddo + call read_attribute(dsfg, 'bk', values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading bk' + call stop2(29) + endif + do k=1,nlevs+1 + bk(nlevs-k+2) = values_1d(k) + enddo + else + ! 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(20) + end if + endif + + u_ind = getindex(vars3d, 'u') !< indices in the control 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) + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + 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) + 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)) + allocate(ugtmp(nlons*nlats,nlevs),vgtmp(nlons*nlats,nlevs)) + endif +! 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 .and. .not. use_gfs_ncio) then + idate = sighead%idate + fhour = sighead%fhour + else if (use_gfs_ncio) then + idate(3)=idat(3) !day + idate(2)=idat(2) !mon + idate(4)=idat(4) !yr + idate(1)=idat(1) !hr + fhour = nfhour + else if (use_gfs_nemsio) then + idate(3)=idat(3) + idate(2)=idat(2) + idate(4)=idat(1) + idate(1)=idat(4) + fhour = nfhour + endif + fha=zero; ida=0; jda=0 + fha(2)=fhour ! relative time interval in hours + ida(1)=idate(4) ! year + ida(2)=idate(2) ! month + ida(3)=idate(3) ! day + ida(4)=0 ! time zone + ida(5)=idate(1) ! hour + call w3movdat(fha,ida,jda) +! +! INPUT VARIABLES: +! RINC REAL (5) NCEP RELATIVE TIME INTERVAL +! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) +! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! +! OUTPUT VARIABLES: +! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! (JDAT IS LATER THAN IDAT IF TIME INTERVAL IS POSITIVE.) + iadate(1)=jda(5) ! hour + iadate(2)=jda(2) ! mon + iadate(3)=jda(3) ! day + iadate(4)=jda(1) ! year + if (nproc .eq. 0) then + print *,'idate = ',idate + print *,'iadate = ',iadate + end if + + if (.not. use_gfs_nemsio .and. .not. use_gfs_ncio) then ! spectral sigio + sighead%idate = iadate + sighead%fhour = zero + ! ensemble info + ! http://www.emc.ncep.noaa.gov/gmb/ens/info/ens_grib.html#gribex + sighead%iens(1) = 3 ! pos pert + sighead%iens(2) = nanal ! ensemble member number + sighead%icen2 = 2 ! sub-center, must be 2 or ens info not used + if (.not. isinitialized) call init_spec_vars(nlons,nlats,sighead%jcap,4) + ! allocate new sigdata structure for increments. + call sigio_aldata(sighead,sigdata_inc,ierr) + ! convert to increment to spectral coefficients. +!$omp parallel do private(k,nt,ug,vg,divspec,vrtspec) shared(grdin,sigdata_inc) + do k=1,nlevs + 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 + + 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 + + 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. + 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 + psg = vg + vg = log(vg/10._r_kind) ! convert back to centibars. + call sptez_s(divspec,vg,-1) + sigdata%ps = divspec + + else if (use_gfs_nemsio) then ! nemsio + gfileout = gfilein + + nfhour = 0 ! new forecast hour, zero at analysis time + nfminute = 0 + nfsecondn = 0 + nfsecondd = 100 ! default for denominator + + !iadate = hh/mm/dd/yyyy + !jdate = yyyy/mm/dd/hh/min/secn/secd + + jdate(1) = iadate(4) ! analysis year + jdate(2) = iadate(2) ! analysis month + jdate(3) = iadate(3) ! analysis day + jdate(4) = iadate(1) ! analysis hour + jdate(5) = nfminute ! analysis minute + jdate(6) = nfsecondn ! analysis scaled seconds + jdate(7) = nfsecondd ! analysis seconds multiplier + + call nemsio_open(gfileout,filenameout,'WRITE',iret=iret,& + 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) + + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_open for output, iret=',iret + call stop2(23) + end if + +! read/write orographay + call nemsio_readrecv(gfilein,'hgt','sfc',1,nems_wrk,iret=iret) + call nemsio_writerecv(gfileout,'hgt','sfc',1,nems_wrk,iret=iret) + + 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. + 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) + 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) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(dpres), iret=',iret + call stop2(23) + endif + nems_wrk = nems_wrk + 100_r_kind*psg + call nemsio_writerecv(gfileout,'dpres','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(dpres), iret=',iret + call stop2(23) + endif + enddo + endif + psg = psfg + ug ! first guess + increment + nems_wrk = 100_r_kind*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 + call stop2(23) + endif + else if (use_gfs_ncio) then + dsanl = create_dataset(filenameout, dsfg, copy_vardata=.true., nocompress=nocompress, errcode=iret) + if (iret /= 0) then + print *,'error creating netcdf file' + call stop2(29) + endif + deallocate(values_1d) + allocate(values_1d(1)) + values_1d(1)=zero + call write_vardata(dsanl,'time',values_1d,errcode=iret) + if (iret /= 0) then + print *,'error writing time' + call stop2(29) + endif + jdat(1) = iadate(4) + jdat(2) = iadate(2) + jdat(3) = iadate(3) + jdat(4) = iadate(1) + jdat(5) = jda(6); jdat(6) = jda(7) + time_units = get_time_units_from_idate(jdat) + call write_attribute(dsanl,'units',time_units,'time',errcode=iret) + if (iret /= 0) then + print *,'error writing time units attribute' + call stop2(29) + endif + call read_vardata(dsfg,'pressfc',values_2d,errcode=iret) + if (iret /= 0) then + print *,'error reading pressfc' + call stop2(29) + endif + psfg = 0.01*reshape(values_2d,(/nlons*nlats/)) + ug = 0_r_kind + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),ug) + endif + ! add increment to background. + psg = psfg + ug ! analysis pressure in mb. + values_2d = 100.*reshape(psg,(/nlons,nlats/)) + call write_vardata(dsanl,'pressfc',values_2d,errcode=iret) + if (iret /= 0) then + print *,'error writing pressfc' + call stop2(29) + endif + !print *,'nanal,min/max psfg,min/max inc',nanal,minval(values_2d),maxval(values_2d),minval(ug),maxval(ug) + if (has_var(dsfg,'dpres')) then + call read_vardata(dsfg,'dpres',ug3d) + allocate(vg3d(nlons,nlats,nlevs)) + ! infer dpres increment from ps increment + do k=1,nlevs + vg = ug*(bk(k)-bk(k+1)) ! ug is ps increment + vg3d(:,:,nlevs-k+1) = ug3d(:,:,nlevs-k+1) +& + 100_r_kind*reshape(vg,(/nlons,nlats/)) + enddo + if (has_attr(dsfg, 'nbits', 'dpres') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'dpres') + ug3d = vg3d + call quantize_data(ug3d, vg3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'dpres',errcode=iret) + if (iret /= 0) then + print *,'error writing dpres attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'dpres',vg3d,errcode=iret) + if (iret /= 0) then + print *,'error writing dpres' + call stop2(29) + endif + endif + endif + + if (pst_ind > 0) then + !==> first guess pressure at interfaces. + do k=1,nlevs+1 + pressi(:,k)=ak(k)+bk(k)*psfg ! psfg in mb, ak has been scaled by 0.01 + 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 ! psg in mb, ak has been scaled by 0.01 + 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 + if (use_gfs_ncio) then + call read_vardata(dsfg,'ugrd',ug3d,errcode=iret) + if (iret /= 0) then + print *,'error reading ugrd' + call stop2(29) + endif + call read_vardata(dsfg,'vgrd',vg3d,errcode=iret) + if (iret /= 0) then + print *,'error reading vgrd' + call stop2(29) + endif + endif + do k=1,nlevs +! re-calculate vertical integral of mass flux div for first-guess + if (use_gfs_nemsio) then + call nemsio_readrecv(gfilein,'ugrd','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(ugrd), iret=',iret + call stop2(23) + endif + ug = nems_wrk + call nemsio_readrecv(gfilein,'vgrd','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(vgrd), iret=',iret + call stop2(23) + endif + vg = nems_wrk + else if (use_gfs_ncio) then + ug = reshape(ug3d(:,:,nlevs-k+1),(/nlons*nlats/)) + vg = reshape(vg3d(:,:,nlevs-k+1),(/nlons*nlats/)) + else + divspec = sigdata%d(:,k); vrtspec = sigdata%z(:,k) + call sptezv_s(divspec,vrtspec,ug,vg,1) + endif + ug = ug*dpfg(:,k) + vg = vg*dpfg(:,k) + call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt + call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd + enddo + + ! analyzed ps tend increment + call copyfromgrdin(grdin(:,levels(n3d) + pst_ind,nb,ne),pstend2) + pstendfg = sum(vmassdiv,2) + vmassdivinc = vmassdiv + if (nanal .eq. 1) then + print *,'time level ',nb + print *,'--------------------' + print *,nanal,'min/max pstendfg',minval(pstendfg),maxval(pstendfg) + print *,nanal,'min/max pstend inc',minval(pstend2),maxval(pstend2) + endif + pstend2 = pstend2 + pstendfg ! add to background ps tend + + endif ! if pst_ind > 0 + + if (.not. use_gfs_nemsio .and. .not. use_gfs_ncio) then + ! add increment to first guess in spectral space. +!$omp parallel do private(k,nt,ug,vg,vrtspec,divspec) shared(sigdata,sigdata_inc,vmassdiv,dpanl) + do k=1,nlevs + +! add increments in spectral space + 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,sighead%ntrac + sigdata%q(:,k,nt) = sigdata%q(:,k,nt) + sigdata_inc%q(:,k,nt) + enddo + + 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) + ug = ug*dpanl(:,k) + vg = vg*dpanl(:,k) + call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt + call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd + endif + + enddo +!$omp end parallel do + + ! don't need sigdata_inc anymore. + call sigio_axdata(sigdata_inc,ierr) + else if (use_gfs_nemsio) then + 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) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(ugrd), iret=',iret + call stop2(23) + endif + 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 (pst_ind < 0) then + nems_wrk = ug + call nemsio_writerecv(gfileout,'ugrd','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(ugrd), iret=',iret + call stop2(23) + endif + else + ugtmp(:,k) = ug ! save analysis u if pst_ind>0 + endif + + call nemsio_readrecv(gfilein,'vgrd','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(vgrd), iret=',iret + call stop2(23) + endif + 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 (pst_ind < 0) then + nems_wrk = vg + call nemsio_writerecv(gfileout,'vgrd','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(vgrd), iret=',iret + call stop2(23) + endif + else + vgtmp(:,k) = vg ! save analysis v if pst_ind>0 + endif + + 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 + call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd + end if + + call nemsio_readrecv(gfilein,'tmp','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(tmp), iret=',iret + call stop2(23) + endif + call nemsio_readrecv(gfilein,'spfh','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(spfh), iret=',iret + call stop2(23) + endif + nems_wrk = nems_wrk * ( 1.0 + fv*nems_wrk2 ) !Convert T to Tv + 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 + 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 + ! ps in Pa here, need to multiply ak by 100. + delzb=delzb*log((100_r_kind*ak(k)+bk(k)*nems_wrk2)/(100_r_kind*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 !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)) + work(i) = min(one,work(i)) + enddo + endif + call nemsio_writerecv(gfileout,'tmp','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(tmp), iret=',iret + call stop2(23) + endif + nems_wrk = vg + call nemsio_writerecv(gfileout,'spfh','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(spfh), iret=',iret + call stop2(23) + endif + 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 ! ug is analysis Tv + ! ps in Pa here, need to multiply ak by 100. + ug=ug*log((100_r_kind*ak(k)+bk(k)*vg)/(100_r_kind*ak(k+1)+bk(k+1)*vg)) + ug=ug-delzb + call nemsio_readrecv(gfilein,'delz','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + 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 + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(delz), iret=',iret + call stop2(23) + endif + endif + + call nemsio_readrecv(gfilein,'o3mr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(o3mr), iret=',iret + call stop2(23) + endif + 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 call nemsio_writerecv(gfileout,'o3mr','mid layer',k,nems_wrk,iret=iret) if (iret/=0) then @@ -1112,7 +2540,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n call stop2(23) endif - if ( .not. use_full_hydro) then + 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(clwmr), iret=',iret @@ -1146,7 +2574,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(icmr), iret=',iret call stop2(23) endif - + field = 'rwmr'; hasfield = checkfield(field,recname,nrecs) if (hasfield) then call nemsio_readrecv(gfilein,'rwmr','mid layer',k,nems_wrk2,iret=iret) @@ -1159,7 +2587,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n 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 @@ -1191,8 +2619,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n endif endif endif - else - ! Update clwmr + 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 @@ -1209,7 +2637,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(clwmr), iret=',iret call stop2(23) endif - ! Update icmr + ! 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 @@ -1226,7 +2654,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(icmr), iret=',iret call stop2(23) endif - ! Update rwmr + ! 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 @@ -1243,7 +2671,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(rwmr), iret=',iret call stop2(23) endif - ! Update snmr + ! 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 @@ -1260,7 +2688,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(snmr), iret=',iret call stop2(23) endif - ! Update grle + ! 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 @@ -1292,187 +2720,1401 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n 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 + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(dzdt), iret=',iret + call stop2(23) + endif + call nemsio_writerecv(gfileout,'dzdt','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(dzdt), iret=',iret + call stop2(23) + endif + endif + enddo + else if (use_gfs_ncio) then + call read_vardata(dsfg,'ugrd',ug3d,errcode=iret) + if (iret /= 0) then + print *,'error reading ugrd' + call stop2(29) + endif + do k=1,nlevs + ug = 0_r_kind + if (u_ind > 0) then + call copyfromgrdin(grdin(:,levels(u_ind-1) + k,nb,ne),ug) + endif + values_2d = reshape(ug,(/nlons,nlats/)) + ug3d(:,:,nlevs-k+1) = ug3d(:,:,nlevs-k+1) + values_2d + if (pst_ind > 0) then + ugtmp(:,k) = reshape(ug3d(:,:,nlevs-k+1),(/nlons*nlats/)) + endif + enddo + if (has_attr(dsfg, 'nbits', 'ugrd') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'ugrd') + if (.not. allocated(vg3d)) allocate(vg3d(nlons,nlats,nlevs)) + vg3d = ug3d + call quantize_data(vg3d, ug3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'ugrd',errcode=iret) + if (iret /= 0) then + print *,'error writing ugrd attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'ugrd',ug3d,errcode=iret) + if (iret /= 0) then + print *,'error writing ugrd' + call stop2(29) + endif + call read_vardata(dsfg,'vgrd',vg3d,errcode=iret) + if (iret /= 0) then + print *,'error reading vgrd' + call stop2(29) + endif + do k=1,nlevs + vg = 0_r_kind + if (v_ind > 0) then + call copyfromgrdin(grdin(:,levels(v_ind-1) + k,nb,ne),vg) + endif + values_2d = reshape(vg,(/nlons,nlats/)) + vg3d(:,:,nlevs-k+1) = vg3d(:,:,nlevs-k+1) + values_2d + if (pst_ind > 0) then + vgtmp(:,k) = reshape(vg3d(:,:,nlevs-k+1),(/nlons*nlats/)) + endif + enddo + if (has_attr(dsfg, 'nbits', 'vgrd') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'vgrd') + ug3d = vg3d + call quantize_data(ug3d, vg3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'vgrd',errcode=iret) + if (iret /= 0) then + print *,'error writing vgrd attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'vgrd',vg3d,errcode=iret) + if (iret /= 0) then + print *,'error writing vgrd' + call stop2(29) + endif + if (pst_ind > 0) then + do k=1,nlevs + ug = ugtmp(:,k)*dpanl(:,k) + vg = vgtmp(:,k)*dpanl(:,k) + call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt + call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd + enddo + end if + + ! read sensible temp and specific humidity + call read_vardata(dsfg,'tmp',ug3d,errcode=iret) + if (iret /= 0) then + print *,'error reading tmp' + call stop2(29) + endif + call read_vardata(dsfg,'spfh',vg3d,errcode=iret) + if (iret /= 0) then + print *,'error reading spfh' + call stop2(29) + endif + allocate(tv_bg(nlons,nlats,nlevs),tv_anal(nlons,nlats,nlevs)) + tv_bg = ug3d * ( 1.0 + fv*vg3d ) !Convert T to Tv + call read_vardata(dsfg,'pressfc',values_2d,errcode=iret) + if (iret /= 0) then + print *,'error reading pressfc' + call stop2(29) + endif + if (allocated(values_1d)) deallocate(values_1d) + allocate(values_1d(nlons*nlats)) + values_1d = reshape(values_2d,(/nlons*nlats/)) + ! add Tv,q increment to background + do k=1,nlevs + 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 + values_2d = reshape(ug,(/nlons,nlats/)) + tv_anal(:,:,nlevs-k+1) = tv_bg(:,:,nlevs-k+1) + values_2d + values_2d = reshape(vg,(/nlons,nlats/)) + vg3d(:,:,nlevs-k+1) = vg3d(:,:,nlevs-k+1) + values_2d + enddo + ! now tv_anal is analysis Tv, vg3d is analysis spfh + if (cliptracers) where (vg3d < clip) vg3d = clip + + ! write analysis T + allocate(values_3d(nlons,nlats,nlevs)) + allocate(tmp_anal(nlons,nlats,nlevs)) + tmp_anal = tv_anal/(1. + fv*vg3d) ! convert Tv back to T, save q as vg3d + values_3d = tmp_anal + if (has_attr(dsfg, 'nbits', 'tmp') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'tmp') + call quantize_data(tmp_anal, values_3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'tmp',errcode=iret) + if (iret /= 0) then + print *,'error writing tmp attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'tmp',values_3d,errcode=iret) ! write T + if (iret /= 0) then + print *,'error writing tmp' + call stop2(29) + endif + + ! write analysis delz + if (has_var(dsfg,'delz')) then + allocate(delzb(nlons*nlats)) + call read_vardata(dsfg,'delz',values_3d) + vg = 0_r_kind + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),vg) + endif + vg = values_1d + vg*100_r_kind ! analysis ps (values_1d is background ps) + do k=1,nlevs + ug=(rd/grav)*reshape(tv_anal(:,:,nlevs-k+1),(/nlons*nlats/)) + ! ps in Pa here, need to multiply ak by 100. + ug=ug*log((100_r_kind*ak(k)+bk(k)*vg)/(100_r_kind*ak(k+1)+bk(k+1)*vg)) + ! ug is hydrostatic analysis delz inferred from analysis ps,Tv + ! delzb is hydrostatic background delz inferred from background ps,Tv + delzb=(rd/grav)*reshape(tv_bg(:,:,nlevs-k+1),(/nlons*nlats/)) + delzb=delzb*log((100_r_kind*ak(k)+bk(k)*values_1d)/(100_r_kind*ak(k+1)+bk(k+1)*values_1d)) + ug3d(:,:,nlevs-k+1)=values_3d(:,:,nlevs-k+1) +& + reshape(delzb-ug,(/nlons,nlats/)) + enddo + !print *,'min/max delz',minval(values_3d),maxval(values_3d),& + ! minval(ug3d),maxval(ug3d) + if (has_attr(dsfg, 'nbits', 'delz') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'delz') + values_3d = ug3d + call quantize_data(values_3d, ug3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'delz',errcode=iret) + if (iret /= 0) then + print *,'error writing delz attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'delz',ug3d,errcode=iret) ! write delz + if (iret /= 0) then + print *,'error writing delz' + call stop2(29) + endif + endif + deallocate(tv_anal,tv_bg) ! keep tmp_anal + + ! write analysis q (still stored in vg3d) + if (has_attr(dsfg, 'nbits', 'spfh') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'spfh') + values_3d = vg3d + call quantize_data(values_3d, vg3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'spfh',errcode=iret) + if (iret /= 0) then + print *,'error writing spfh attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'spfh',vg3d,errcode=iret) ! write q + if (iret /= 0) then + print *,'error writing spfh' + call stop2(29) + endif + + ! write clwmr, icmr + call read_vardata(dsfg,'clwmr',ug3d,errcode=iret) + if (iret /= 0) then + print *,'error reading clwmr' + call stop2(29) + endif + if (imp_physics == 11) then + call read_vardata(dsfg,'icmr',vg3d,errcode=iret) + if (iret /= 0) then + print *,'error reading icmr' + call stop2(29) + endif + endif + do k=1,nlevs + ug = 0_r_kind + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+k,nb,ne),ug) + endif + if (imp_physics == 11) then + work = -r0_05 * (reshape(tmp_anal(:,:,nlevs-k+1),(/nlons*nlats/)) - t0c) + do i=1,nlons*nlats + work(i) = max(zero,work(i)) + work(i) = min(one,work(i)) + enddo + vg = ug * work ! cloud ice + ug = ug * (one - work) ! cloud water + vg3d(:,:,nlevs-k+1) = vg3d(:,:,nlevs-k+1) +& + reshape(vg,(/nlons,nlats/)) + endif + ug3d(:,:,nlevs-k+1) = ug3d(:,:,nlevs-k+1) + & + reshape(ug,(/nlons,nlats/)) + enddo + deallocate(tmp_anal) + if (cw_ind > 0) then + if (has_attr(dsfg, 'nbits', 'clwmr') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'clwmr') + values_3d = ug3d + call quantize_data(values_3d, ug3d, nbits, compress_err) + if (cliptracers) where (ug3d < clip) ug3d = clip + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'clwmr',errcode=iret) + if (iret /= 0) then + print *,'error writing clwmr attribute' + call stop2(29) + endif + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + endif + call write_vardata(dsanl,'clwmr',ug3d,errcode=iret) ! write clwmr + if (iret /= 0) then + print *,'error writing clwmr' + call stop2(29) + endif + if (imp_physics == 11) then + if (cw_ind > 0) then + if (has_attr(dsfg, 'nbits', 'clwmr') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'clwmr') + values_3d = vg3d + call quantize_data(values_3d, vg3d, nbits, compress_err) + if (cliptracers) where (vg3d < clip) vg3d = clip + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'icmr',errcode=iret) + if (iret /= 0) then + print *,'error writing icmr attribute' + call stop2(29) + endif + endif + if (cliptracers) where (vg3d < clip) vg3d = clip + endif + call write_vardata(dsanl,'icmr',vg3d,errcode=iret) ! write icmr + if (iret /= 0) then + print *,'error writing icmr' + call stop2(29) + endif + endif + + ! write analysis ozone + call read_vardata(dsfg, 'o3mr', vg3d,errcode=iret) + if (iret /= 0) then + print *,'error reading o3mr' + call stop2(29) + endif + do k=1,nlevs + ug = 0_r_kind + if (oz_ind > 0) then + call copyfromgrdin(grdin(:,levels(oz_ind-1)+k,nb,ne),ug) + endif + vg3d(:,:,nlevs-k+1) = vg3d(:,:,nlevs-k+1) + & + reshape(ug,(/nlons,nlats/)) + enddo + if (oz_ind > 0) then + if (has_attr(dsfg, 'nbits', 'o3mr') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'o3mr') + values_3d = vg3d + call quantize_data(values_3d, vg3d, nbits, compress_err) + if (cliptracers) where (vg3d < clip) vg3d = clip + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'o3mr',errcode=iret) + if (iret /= 0) then + print *,'error writing o3mr attribute' + call stop2(29) + endif + endif + if (cliptracers) where (vg3d < clip) vg3d = clip + endif + call write_vardata(dsanl,'o3mr',vg3d) ! write o3mr + if (iret /= 0) then + print *,'error writing o3mr' + call stop2(29) + endif + endif + + if (allocated(delzb)) deallocate(delzb) + if (allocated(recname)) deallocate(recname) + if (imp_physics == 11 .and. (.not. use_full_hydro)) deallocate(work) + + if (pst_ind > 0) then + + vmassdivinc = vmassdiv - vmassdivinc ! analyis - first guess VIMFD + ! (VIMFD = vertically integrated mass flux divergence) + pstend1 = sum(vmassdiv,2) + if (nanal .eq. 1) then + print *,nanal,'min/max analysis ps tend',minval(pstend1),maxval(pstend1) + print *,nanal,'min/max analyzed ps tend',minval(pstend2),maxval(pstend2) + endif + ! vmass is vertical integral of dp**2 + vmass = 0_r_kind + do k=1,nlevs + ! case 2 (4.3.1.2) in GEOS DAS document. + ! (adjustment proportional to mass in layer) + vmass = vmass + dpanl(:,k)**2 + ! case 3 (4.3.1.3) in GEOS DAS document. + ! (adjustment propotional to mass-flux div increment) + !vmass = vmass + vmassdivinc(:,k)**2 + enddo + ! adjust wind field in analysis so pstend is consistent with pstend2 + ! (analyzed pstend) +!$omp parallel do private(k,nt,ug,vg,uginc,vginc,vrtspec,divspec) shared(sigdata,vmassdiv,vmassdivinc,dpanl) + do k=1,nlevs + ! case 2 + ug = (pstend2 - pstend1)*dpanl(:,k)**2/vmass + ! case 3 + !ug = (pstend2 - pstend1)*vmassdivinc(:,k)**2/vmass + call sptez_s(divspec,ug,-1) ! divgrd to divspec + 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)',& + minval(uginc/dpanl(:,k)),maxval(uginc/dpanl(:,k)) + endif + if (use_gfs_nemsio .or. use_gfs_ncio) then + ugtmp(:,k) = (ugtmp(:,k)*dpanl(:,k) + uginc)/dpanl(:,k) + vgtmp(:,k) = (vgtmp(:,k)*dpanl(:,k) + vginc)/dpanl(:,k) + ug = ugtmp(:,k); vg = vgtmp(:,k) + else + ! adjust spectral div,vort + ! (vrtspec,divspec to u,v, add increment to u,v, then convert + ! back go vrtspec,divspec) + divspec = sigdata%d(:,k); vrtspec = sigdata%z(:,k) + call sptezv_s(divspec,vrtspec,ug,vg,1) + ug = (ug*dpanl(:,k) + uginc)/dpanl(:,k) + vg = (vg*dpanl(:,k) + vginc)/dpanl(:,k) + call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt + sigdata%d(:,k) = divspec; sigdata%z(:,k) = vrtspec + ! recompute u,v + divspec = sigdata%d(:,k); vrtspec = sigdata%z(:,k) + call sptezv_s(divspec,vrtspec,ug,vg,1) + endif +! check result.. + ug = ug*dpanl(:,k); vg = vg*dpanl(:,k) + 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 + + ! should be same as analyzed ps tend + psfg = sum(vmassdiv,2) + !if (nanal .eq. 1) then + ! open(919,file='pstend.dat',form='unformatted',access='direct',recl=nlons*nlats) + ! write(919,rec=1) pstendfg + ! write(919,rec=2) pstend2 + ! write(919,rec=3) psfg + ! write(919,rec=4) pstend1 + ! close(919) + !endif + if (nanal .eq. 1) then + print *,nanal,'min/max adjusted ps tend',minval(psfg),maxval(psfg) + print *,nanal,'min/max diff between adjusted and analyzed ps tend',& + minval(pstend2-psfg),maxval(pstend2-psfg) + endif + + endif ! if pst_ind > 0 + + if (.not. use_gfs_nemsio .and. .not. use_gfs_ncio) then + ! clip tracers. + if (cliptracers) then + clip = tiny_r_kind +!$omp parallel do private(k,nt,vg,divspec) shared(sigdata,clip) + do k=1,nlevs + 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 + + ! write out analysis. + call sigio_swohdc(iunitsig,filenameout,sighead,sigdata,ierr) + ! deallocate sigdata structure. + call sigio_axdata(sigdata,ierr) + else if (use_gfs_ncio) then + if (pst_ind > 0) then + do k=1,nlevs + ug3d(:,:,nlevs-k+1) = reshape(ugtmp(:,k),(/nlons,nlats/)) + vg3d(:,:,nlevs-k+1) = reshape(vgtmp(:,k),(/nlons,nlats/)) + enddo + if (has_attr(dsfg, 'nbits', 'ugrd') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'ugrd') + values_3d = ug3d + call quantize_data(values_3d, ug3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'ugrd',errcode=iret) + if (iret /= 0) then + print *,'error writing ugrd attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'ugrd',ug3d,errcode=iret) ! write u + if (iret /= 0) then + print *,'error writing ugrd' + call stop2(29) + endif + if (has_attr(dsfg, 'nbits', 'vgrd') .and. .not. nocompress) then + call read_attribute(dsfg, 'nbits', nbits, 'vgrd') + values_3d = vg3d + call quantize_data(values_3d, vg3d, nbits, compress_err) + call write_attribute(dsanl,& + 'max_abs_compression_error',compress_err,'vgrd',errcode=iret) + if (iret /= 0) then + print *,'error writing vgrd attribute' + call stop2(29) + endif + endif + call write_vardata(dsanl,'vgrd',vg3d,errcode=iret) ! write v + if (iret /= 0) then + print *,'error writing ugrd' + call stop2(29) + endif + deallocate(ugtmp,vgtmp) + endif + else if (use_gfs_nemsio) then + if (pst_ind > 0) then + ! update u,v + do k=1,nlevs + nems_wrk = ugtmp(:,k) + call nemsio_writerecv(gfileout,'ugrd','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(ugrd), iret=',iret call stop2(23) endif - call nemsio_writerecv(gfileout,'dzdt','mid layer',k,nems_wrk2,iret=iret) + nems_wrk = vgtmp(:,k) + call nemsio_writerecv(gfileout,'vgrd','mid layer',k,nems_wrk,iret=iret) if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(dzdt), iret=',iret + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(vgrd), iret=',iret call stop2(23) endif - endif - enddo - endif !if (.not. use_gfs_nemsio) + enddo + deallocate(ugtmp,vgtmp) + endif + endif + + if (allocated(ug3d)) deallocate(ug3d) + if (allocated(vg3d)) deallocate(vg3d) + if (allocated(values_3d)) deallocate(values_3d) + if (allocated(values_2d)) deallocate(values_2d) + if (allocated(values_1d)) deallocate(values_1d) + + if (pst_ind > 0) then + deallocate(pressi,dpanl,dpfg) + deallocate(pstend1,pstend2,pstendfg,vmass) + deallocate(vmassdiv) + deallocate(vmassdivinc) + endif + + if (use_gfs_nemsio) then + call nemsio_close(gfilein,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem closing nemsio fg dataset, iret=',iret + call stop2(23) + endif + call nemsio_close(gfileout,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem closing nemsio anal dataset, iret=',iret + call stop2(23) + endif + else if (use_gfs_ncio) then + call close_dataset(dsfg,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem closing netcdf fg dataset, iret=',iret + call stop2(23) + endif + call close_dataset(dsanl,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem closing netcdf anal dataset, iret=',iret + call stop2(23) + endif + 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 + + subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use netcdf + use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,& + datestring,nhr_anal + use constants, only: grav + use mpi + use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + read_attribute, close_dataset, get_dim, read_vardata,& + create_dataset, get_idate_from_time_units, & + get_time_units_from_idate, write_vardata, & + write_attribute, quantize_data, has_var, has_attr + 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,1), intent(inout) :: grdin + logical, intent(in) :: no_inflate_flag + logical:: use_full_hydro + character(len=500):: filenamein, filenameout + integer(i_kind) :: i,j,k, nb, ne, nanal + character(len=3) charnanal + type(Dataset) :: dsfg + + integer(i_kind) :: krev, iret + real(r_kind), dimension(nlevs+1) :: ak,bk + real(r_kind) clip + + integer :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind + integer :: ps_ind, pst_ind + integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind + + ! netcdf things + integer(i_kind) :: dimids3(3), ncstart(3), nccount(3) + integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid + integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & + hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & + tvarid, sphumvarid, liqwatvarid, o3varid, icvarid + integer(i_kind) :: iadateout + + ! fixed fields such as lat, lon, levs + real(r_kind),dimension(nlons) :: deglons + real(r_kind),dimension(nlats) :: deglats + real(r_kind),dimension(nlevs) :: levsout + real(r_kind),dimension(nlevs+1) :: ilevsout + + ! increment + real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work + real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout + real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl + real(r_kind), allocatable, dimension(:,:) :: values_2d + real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d + + use_full_hydro = .false. + clip = tiny_r_kind + read(datestring,*) iadateout + + ncstart = (/1, 1, 1/) + nccount = (/nlons, nlats, nlevs/) + + 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 + filenameout = trim(adjustl(datapath))//trim(adjustl(incfileprefixes(nb)))//"nimem"//charnanal + else + filenameout = trim(adjustl(datapath))//trim(adjustl(incfileprefixes(nb)))//"mem"//charnanal + end if + filenamein = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nb)))//"mem"//charnanal + + ! create the output netCDF increment file + call nccheck_incr(nf90_create(path=trim(filenameout), cmode=nf90_netcdf4, ncid=ncid_out)) + + ! create dimensions based on analysis resolution, not guess + call nccheck_incr(nf90_def_dim(ncid_out, "lon", nlons, lon_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "lat", nlats, lat_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "lev", nlevs, lev_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "ilev", nlevs+1, ilev_dimid)) + dimids3 = (/ lon_dimid, lat_dimid, lev_dimid /) + ! create variables + call nccheck_incr(nf90_def_var(ncid_out, "lon", nf90_real, (/lon_dimid/), lonvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "lat", nf90_real, (/lat_dimid/), latvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "lev", nf90_real, (/lev_dimid/), levvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "pfull", nf90_real, (/lev_dimid/), pfullvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "ilev", nf90_real, (/ilev_dimid/), ilevvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "hyai", nf90_real, (/ilev_dimid/), hyaivarid)) + call nccheck_incr(nf90_def_var(ncid_out, "hybi", nf90_real, (/ilev_dimid/), hybivarid)) + call nccheck_incr(nf90_def_var(ncid_out, "u_inc", nf90_real, dimids3, uvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "v_inc", nf90_real, dimids3, vvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "delp_inc", nf90_real, dimids3, delpvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "delz_inc", nf90_real, dimids3, delzvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "T_inc", nf90_real, dimids3, tvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "sphum_inc", nf90_real, dimids3, sphumvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "liq_wat_inc", nf90_real, dimids3, liqwatvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "o3mr_inc", nf90_real, dimids3, o3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "icmr_inc", nf90_real, dimids3, icvarid)) + ! place global attributes to serial calc_increment output + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & + "global analysis increment from writeincrement")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time", iadateout)) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "IAU_hour_from_guess", nhr_anal(nb))) + ! add units to lat/lon because that's what the calc_increment utility has + call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units", "degrees_east")) + call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units", "degrees_north")) + ! end the netCDF file definition + call nccheck_incr(nf90_enddef(ncid_out)) + + u_ind = getindex(vars3d, 'u') !< indices in the control 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) + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + 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) + 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 ) + + dsfg = open_dataset(filenamein) + call read_attribute(dsfg, 'ak', values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading ak' + call stop2(29) + endif + do k=1,nlevs+1 + ak(nlevs-k+2) = 0.01_r_kind*values_1d(k) + enddo + call read_attribute(dsfg, 'bk', values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading bk' + call stop2(29) + endif + do k=1,nlevs+1 + bk(nlevs-k+2) = values_1d(k) + enddo + + ! levels + do k=1,nlevs + levsout(k) = float(k) + ilevsout(k) = float(k) + end do + ilevsout(nlevs+1) = float(nlevs+1) + + ! longitudes + call read_vardata(dsfg, 'grid_xt', values_1d, errcode=iret) + deglons(:) = values_1d + call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, & + start = (/1/), count = (/nlons/))) + + call read_vardata(dsfg, 'grid_yt', values_1d, errcode=iret) + ! latitudes + do j=1,nlats + deglats(nlats-j+1) = values_1d(j) + end do + + call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, & + start = (/1/), count = (/nlats/))) + + ! write to file + call nccheck_incr(nf90_put_var(ncid_out, levvarid, sngl(levsout), & + start = (/1/), count = (/nlevs/))) + ! pfull + call nccheck_incr(nf90_put_var(ncid_out, pfullvarid, sngl(levsout), & + start = (/1/), count = (/nlevs/))) + ! ilev + call nccheck_incr(nf90_put_var(ncid_out, ilevvarid, sngl(ilevsout), & + start = (/1/), count = (/nlevs+1/))) + ! hyai + call nccheck_incr(nf90_put_var(ncid_out, hyaivarid, sngl(ilevsout), & + start = (/1/), count = (/nlevs+1/))) + ! hybi + call nccheck_incr(nf90_put_var(ncid_out, hybivarid, sngl(ilevsout), & + start = (/1/), count = (/nlevs+1/))) + + allocate(inc3d(nlons,nlats,nccount(3))) + allocate(inc3d2(nlons,nlats,nccount(3))) + allocate(inc3dout(nlons,nlats,nccount(3))) + ! u increment + do k=1,nlevs + krev = nlevs-k+1 + inc(:) = zero + if (u_ind > 0) then + call copyfromgrdin(grdin(:,levels(u_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,k) = reshape(inc,(/nlons,nlats/)) + end do + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('u_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, uvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + ! v increment + do k=1,nlevs + krev = nlevs-k+1 + inc(:) = zero + if (u_ind > 0) then + call copyfromgrdin(grdin(:,levels(v_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,k) = reshape(inc,(/nlons,nlats/)) + end do + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('v_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, vvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! delp increment + psinc(:) = zero + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),psinc) + endif + do k=1,nlevs + krev = nlevs-k+1 + inc(:) = zero + inc = psinc*(bk(krev)-bk(krev+1))*100_r_kind + inc3d(:,:,k) = reshape(inc,(/nlons,nlats/)) + end do + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('delp_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, delpvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! sphum increment + allocate(tmp(nlons,nlats,nccount(3)),tv(nlons,nlats,nccount(3)),q(nlons,nlats,nccount(3))) + allocate(tvanl(nlons,nlats,nccount(3)),tmpanl(nlons,nlats,nccount(3)),qanl(nlons,nlats,nccount(3))) + call read_vardata(dsfg, 'spfh', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading spfh' + call stop2(29) + endif + do k=1,nlevs + krev = nlevs-k+1 + inc(:) = zero + if (q_ind > 0) then + call copyfromgrdin(grdin(:,levels(q_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,k) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,k) = q(:,:,k) + inc3d(:,:,k) + end do + if (cliptracers) where (qanl < clip) qanl = clip + inc3d = qanl - q + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('sphum_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, sphumvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! t increment + call read_vardata(dsfg, 'tmp', tmp, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading tmp' + call stop2(29) + endif + tv = tmp * ( 1.0 + fv*q) + do k=1,nlevs + krev = nlevs-k+1 + inc(:) = zero + if (tv_ind > 0) then + call copyfromgrdin(grdin(:,levels(tv_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,k) = reshape(inc,(/nlons,nlats/)) + tvanl(:,:,k) = tv(:,:,k) + inc3d(:,:,k) + tmpanl(:,:,k) = tvanl(:,:,k)/(1. + fv*qanl(:,:,k)) + end do + inc3d = tmpanl - tmp + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('T_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, tvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! delz increment + inc3d(:,:,:) = zero + if (has_var(dsfg,'delz')) then + allocate(delzb(nlons*nlats)) + call read_vardata(dsfg,'pressfc',values_2d,errcode=iret) + if (allocated(psges)) deallocate(psges) + allocate(psges(nlons*nlats)) + psges = reshape(values_2d,(/nlons*nlats/)) + vg = psges + (psinc*100_r_kind) + do k=1,nlevs + krev = nlevs-k+1 + ug=(rd/grav)*reshape(tvanl(:,:,k),(/nlons*nlats/)) + ! ps in Pa here, need to multiply ak by 100. + ug=ug*log((100_r_kind*ak(krev)+bk(krev)*vg)/(100_r_kind*ak(krev+1)+bk(krev+1)*vg)) + ! ug is hydrostatic analysis delz inferred from analysis ps,Tv + ! delzb is hydrostatic background delz inferred from background ps,Tv + delzb=(rd/grav)*reshape(tv(:,:,k),(/nlons*nlats/)) + delzb=delzb*log((100_r_kind*ak(krev)+bk(krev)*psges)/(100_r_kind*ak(krev+1)+bk(krev+1)*psges)) + inc3d(:,:,k)=reshape(delzb-ug,(/nlons,nlats/)) + end do + end if + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('delz_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, delzvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! o3mr increment + do k=1,nlevs + krev = nlevs-k+1 + inc(:) = zero + if (oz_ind > 0) then + call copyfromgrdin(grdin(:,levels(oz_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,k) = reshape(inc,(/nlons,nlats/)) + end do + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('o3mr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, o3varid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! liq wat increment + ! icmr increment + do k=1,nlevs + krev = nlevs-k+1 + ug = zero + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) + end if + if (imp_physics == 11) then + work = -r0_05 * (reshape(tmpanl(:,:,k),(/nlons*nlats/)) - t0c) + do i=1,nlons*nlats + work(i) = max(zero,work(i)) + work(i) = min(one,work(i)) + enddo + vg = ug * work ! cloud ice + ug = ug * (one - work) ! cloud water + inc3d2(:,:,k) = reshape(vg,(/nlons,nlats/)) + endif + inc3d(:,:,k) = reshape(ug,(/nlons,nlats/)) + enddo + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) + end do + if (should_zero_increments_for('icmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! deallocate things + deallocate(inc3d,inc3d2,inc3dout) + deallocate(tmp,tv,q,tmpanl,tvanl,qanl) + deallocate(delzb,psges) - if (allocated(delzb)) deallocate(delzb) - if (allocated(recname)) deallocate(recname) - if (imp_physics == 11 .and. (.not. use_full_hydro)) deallocate(work) + end do backgroundloop ! loop over backgrounds to read in + end do ensmemloop ! loop over ens members to read in - if (pst_ind > 0) then + return - vmassdivinc = vmassdiv - vmassdivinc ! analyis - first guess VIMFD - ! (VIMFD = vertically integrated mass flux divergence) - pstend1 = sum(vmassdiv,2) - if (nanal .eq. 1) then - print *,nanal,'min/max analysis ps tend',minval(pstend1),maxval(pstend1) - print *,nanal,'min/max analyzed ps tend',minval(pstend2),maxval(pstend2) - endif - ! vmass is vertical integral of dp**2 - vmass = 0_r_kind - do k=1,nlevs - ! case 2 (4.3.1.2) in GEOS DAS document. - ! (adjustment proportional to mass in layer) - vmass = vmass + dpanl(:,k)**2 - ! case 3 (4.3.1.3) in GEOS DAS document. - ! (adjustment propotional to mass-flux div increment) - !vmass = vmass + vmassdivinc(:,k)**2 - enddo - ! adjust wind field in analysis so pstend is consistent with pstend2 - ! (analyzed pstend) -!$omp parallel do private(k,nt,ug,vg,uginc,vginc,vrtspec,divspec) shared(sigdata,vmassdiv,vmassdivinc,dpanl) - do k=1,nlevs - ! case 2 - ug = (pstend2 - pstend1)*dpanl(:,k)**2/vmass - ! case 3 - !ug = (pstend2 - pstend1)*vmassdivinc(:,k)**2/vmass - call sptez_s(divspec,ug,-1) ! divgrd to divspec - 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)',& - minval(uginc/dpanl(:,k)),maxval(uginc/dpanl(:,k)) - endif - if (use_gfs_nemsio) then - ugtmp(:,k) = (ugtmp(:,k)*dpanl(:,k) + uginc)/dpanl(:,k) - vgtmp(:,k) = (vgtmp(:,k)*dpanl(:,k) + vginc)/dpanl(:,k) - ug = ugtmp(:,k); vg = vgtmp(:,k) - else - ! adjust spectral div,vort - ! (vrtspec,divspec to u,v, add increment to u,v, then convert - ! back go vrtspec,divspec) - divspec = sigdata%d(:,k); vrtspec = sigdata%z(:,k) - call sptezv_s(divspec,vrtspec,ug,vg,1) - ug = (ug*dpanl(:,k) + uginc)/dpanl(:,k) - vg = (vg*dpanl(:,k) + vginc)/dpanl(:,k) - call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt - sigdata%d(:,k) = divspec; sigdata%z(:,k) = vrtspec - ! recompute u,v - divspec = sigdata%d(:,k); vrtspec = sigdata%z(:,k) - call sptezv_s(divspec,vrtspec,ug,vg,1) - endif -! check result.. - ug = ug*dpanl(:,k); vg = vg*dpanl(:,k) - 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 + contains +! copying to grdin (calling regtoreduced if reduced grid) + subroutine copyfromgrdin(grdin, field) + implicit none - ! should be same as analyzed ps tend - psfg = sum(vmassdiv,2) - !if (nanal .eq. 1) then - ! open(919,file='pstend.dat',form='unformatted',access='direct',recl=nlons*nlats) - ! write(919,rec=1) pstendfg - ! write(919,rec=2) pstend2 - ! write(919,rec=3) psfg - ! write(919,rec=4) pstend1 - ! close(919) - !endif - if (nanal .eq. 1) then - print *,nanal,'min/max adjusted ps tend',minval(psfg),maxval(psfg) - print *,nanal,'min/max diff between adjusted and analyzed ps tend',& - minval(pstend2-psfg),maxval(pstend2-psfg) - endif + real(r_single), dimension(:), intent(in) :: grdin + real(r_kind), dimension(:), intent(inout) :: field - endif ! if pst_ind > 0 + if (reducedgrid) then + call reducedtoreg(grdin, field) + else + field = grdin + endif - if (.not. use_gfs_nemsio) then - ! clip tracers. - if (cliptracers) then - clip = tiny_r_kind -!$omp parallel do private(k,nt,vg,divspec) shared(sigdata,clip) - do k=1,nlevs - 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 + end subroutine copyfromgrdin - ! write out analysis. - call sigio_swohdc(iunitsig,filenameout,sighead,sigdata,ierr) - ! deallocate sigdata structure. - call sigio_axdata(sigdata,ierr) + end subroutine writeincrement + + subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use netcdf + use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,& + datestring,nhr_anal + use constants, only: grav + use mpi + use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + read_attribute, close_dataset, get_dim, read_vardata,& + create_dataset, get_idate_from_time_units, & + get_time_units_from_idate, write_vardata, & + write_attribute, quantize_data, has_var, has_attr + implicit none + + 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,1), intent(inout) :: grdin + logical, intent(in) :: no_inflate_flag + logical:: use_full_hydro + character(len=500):: filenamein, filenameout + integer(i_kind) :: i,j,k, nb, ne, nanal, imem + character(len=3) charnanal + type(Dataset) :: dsfg + + integer(i_kind), allocatable, dimension(:) :: mem_pe, lev_pe1, lev_pe2, iocomms + integer(i_kind) :: iope, ionumproc, iolevs, krev, ki, iret + real(r_kind), dimension(nlevs+1) :: ak,bk + real(r_kind) clip + + integer :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind + integer :: ps_ind, pst_ind + integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind + + ! netcdf things + integer(i_kind) :: dimids3(3),nccount(3),ncstart(3) + integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid + integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & + hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & + tvarid, sphumvarid, liqwatvarid, o3varid, icvarid + integer(i_kind) :: iadateout + + ! fixed fields such as lat, lon, levs + real(r_kind),dimension(nlons) :: deglons + real(r_kind),dimension(nlats) :: deglats + real(r_kind),dimension(nlevs) :: levsout + real(r_kind),dimension(nlevs+1) :: ilevsout + + ! increment + real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work + real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout + real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl + real(r_kind), allocatable, dimension(:,:) :: values_2d + real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d + + use_full_hydro = .false. + clip = tiny_r_kind + read(datestring,*) iadateout + + ! figure out what member to write and do MPI sub-communicator things + allocate(mem_pe(0:numproc-1)) + allocate(iocomms(nanals)) + imem = 1 + do i=0,numproc-1 + mem_pe(i) = imem + imem = imem + 1 + if (imem > nanals) imem = 1 + end do + nanal = mem_pe(nproc) + + call mpi_comm_split(mpi_comm_world, mem_pe(nproc), nproc, iocomms(mem_pe(nproc)), iret) + call mpi_comm_rank(iocomms(mem_pe(nproc)), iope, iret) + call mpi_comm_size(iocomms(mem_pe(nproc)), ionumproc, iret) + + ! figure out what levels to write on this sub-communicator's PE + allocate(lev_pe1(0:ionumproc-1)) + allocate(lev_pe2(0:ionumproc-1)) + iolevs = nlevs/ionumproc + do i=0,ionumproc-1 + lev_pe1(i) = (iope * iolevs) + 1 + lev_pe2(i) = ((iope + 1) * iolevs) + if (i == ionumproc-1) lev_pe2(i) = lev_pe2(i) + modulo(nlevs, ionumproc) + end do + ncstart = (/1, 1, lev_pe1(iope)/) + nccount = (/nlons, nlats, lev_pe2(iope) - lev_pe1(iope)+1/) + + ! need to distribute grdin to all PEs in this subcommunicator + ! bring all the subdomains back to the main PE + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + call mpi_bcast(grdin,npts*ndim*nbackgrounds, mpi_real4, 0, iocomms(mem_pe(nproc)), iret) + + ! loop through times and do the read + ne = 1 + backgroundloop: do nb=1,nbackgrounds + write(charnanal,'(i3.3)') nanal + + if(no_inflate_flag) then + filenameout = trim(adjustl(datapath))//trim(adjustl(incfileprefixes(nb)))//"nimem"//charnanal else - if (pst_ind > 0) then - ! update u,v - do k=1,nlevs - nems_wrk = ugtmp(:,k) - call nemsio_writerecv(gfileout,'ugrd','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(ugrd), iret=',iret - call stop2(23) - endif - nems_wrk = vgtmp(:,k) - call nemsio_writerecv(gfileout,'vgrd','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(vgrd), iret=',iret - call stop2(23) - endif - enddo - deallocate(ugtmp,vgtmp) + filenameout = trim(adjustl(datapath))//trim(adjustl(incfileprefixes(nb)))//"mem"//charnanal + end if + filenamein = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nb)))//"mem"//charnanal + + ! create the output netCDF increment file + call nccheck_incr(nf90_create(path=trim(filenameout), cmode=ior(nf90_netcdf4, nf90_mpiio), ncid=ncid_out, & + comm = iocomms(mem_pe(nproc)), info = mpi_info_null)) + + ! create dimensions based on analysis resolution, not guess + call nccheck_incr(nf90_def_dim(ncid_out, "lon", nlons, lon_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "lat", nlats, lat_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "lev", nlevs, lev_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "ilev", nlevs+1, ilev_dimid)) + dimids3 = (/ lon_dimid, lat_dimid, lev_dimid /) + ! create variables + call nccheck_incr(nf90_def_var(ncid_out, "lon", nf90_real, (/lon_dimid/), lonvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "lat", nf90_real, (/lat_dimid/), latvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "lev", nf90_real, (/lev_dimid/), levvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "pfull", nf90_real, (/lev_dimid/), pfullvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "ilev", nf90_real, (/ilev_dimid/), ilevvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "hyai", nf90_real, (/ilev_dimid/), hyaivarid)) + call nccheck_incr(nf90_def_var(ncid_out, "hybi", nf90_real, (/ilev_dimid/), hybivarid)) + call nccheck_incr(nf90_def_var(ncid_out, "u_inc", nf90_real, dimids3, uvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, uvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "v_inc", nf90_real, dimids3, vvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, vvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "delp_inc", nf90_real, dimids3, delpvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, delpvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "delz_inc", nf90_real, dimids3, delzvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, delzvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "T_inc", nf90_real, dimids3, tvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, tvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "sphum_inc", nf90_real, dimids3, sphumvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, sphumvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "liq_wat_inc", nf90_real, dimids3, liqwatvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, liqwatvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "o3mr_inc", nf90_real, dimids3, o3varid)) + call nccheck_incr(nf90_var_par_access(ncid_out, o3varid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "icmr_inc", nf90_real, dimids3, icvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, icvarid, nf90_collective)) + ! place global attributes to parallel calc_increment output + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & + "global analysis increment from writeincrement_pnc")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time", iadateout)) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "IAU_hour_from_guess", nhr_anal(nb))) + ! add units to lat/lon because that's what the calc_increment utility has + call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units", "degrees_east")) + call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units", "degrees_north")) + ! end the netCDF file definition + call nccheck_incr(nf90_enddef(ncid_out)) + + u_ind = getindex(vars3d, 'u') !< indices in the control 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) + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + 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) + 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 ) + + dsfg = open_dataset(filenamein, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) + call read_attribute(dsfg, 'ak', values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading ak' + call stop2(29) + endif + do k=1,nlevs+1 + ak(nlevs-k+2) = 0.01_r_kind*values_1d(k) + enddo + call read_attribute(dsfg, 'bk', values_1d,errcode=iret) + if (iret /= 0) then + print *,'error reading bk' + call stop2(29) + endif + do k=1,nlevs+1 + bk(nlevs-k+2) = values_1d(k) + enddo + + if (iope==0) then + ! levels + do k=1,nlevs + levsout(k) = float(k) + ilevsout(k) = float(k) + end do + ilevsout(nlevs+1) = float(nlevs+1) + + ! longitudes + call read_vardata(dsfg, 'grid_xt', values_1d, errcode=iret) + deglons(:) = values_1d + call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, & + start = (/1/), count = (/nlons/))) + + call read_vardata(dsfg, 'grid_yt', values_1d, errcode=iret) + ! latitudes + do j=1,nlats + deglats(nlats-j+1) = values_1d(j) + end do + + call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, & + start = (/1/), count = (/nlats/))) + + ! write to file + call nccheck_incr(nf90_put_var(ncid_out, levvarid, sngl(levsout), & + start = (/1/), count = (/nlevs/))) + ! pfull + call nccheck_incr(nf90_put_var(ncid_out, pfullvarid, sngl(levsout), & + start = (/1/), count = (/nlevs/))) + ! ilev + call nccheck_incr(nf90_put_var(ncid_out, ilevvarid, sngl(ilevsout), & + start = (/1/), count = (/nlevs+1/))) + ! hyai + call nccheck_incr(nf90_put_var(ncid_out, hyaivarid, sngl(ilevsout), & + start = (/1/), count = (/nlevs+1/))) + ! hybi + call nccheck_incr(nf90_put_var(ncid_out, hybivarid, sngl(ilevsout), & + start = (/1/), count = (/nlevs+1/))) + + end if + + allocate(inc3d(nlons,nlats,nccount(3))) + allocate(inc3d2(nlons,nlats,nccount(3))) + allocate(inc3dout(nlons,nlats,nccount(3))) + ! u increment + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (u_ind > 0) then + call copyfromgrdin(grdin(:,levels(u_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + end do + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('u_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, uvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! v increment + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (u_ind > 0) then + call copyfromgrdin(grdin(:,levels(v_ind-1) + krev,nb,ne),inc) endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + end do + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('v_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, vvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! delp increment + psinc(:) = zero + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),psinc) endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + inc = psinc*(bk(krev)-bk(krev+1))*100_r_kind + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + end do + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('delp_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, delpvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) - if (use_gfs_nemsio) then - call nemsio_close(gfilein,iret=iret) - call nemsio_close(gfileout,iret=iret) + ! sphum increment + allocate(tmp(nlons,nlats,nccount(3)),tv(nlons,nlats,nccount(3)),q(nlons,nlats,nccount(3))) + allocate(tvanl(nlons,nlats,nccount(3)),tmpanl(nlons,nlats,nccount(3)),qanl(nlons,nlats,nccount(3))) + call read_vardata(dsfg, 'spfh', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading spfh' + call stop2(29) endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (q_ind > 0) then + call copyfromgrdin(grdin(:,levels(q_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < clip) qanl = clip + inc3d = qanl - q + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('sphum_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, sphumvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) - if (pst_ind > 0) then - deallocate(pressi,dpanl,dpfg) - deallocate(pstend1,pstend2,pstendfg,vmass) - deallocate(vmassdiv) - deallocate(vmassdivinc) + ! t increment + call read_vardata(dsfg, 'tmp', tmp, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + print *,'error reading tmp' + call stop2(29) endif + tv = tmp * ( 1.0 + fv*q) + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (tv_ind > 0) then + call copyfromgrdin(grdin(:,levels(tv_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + tvanl(:,:,ki) = tv(:,:,ki) + inc3d(:,:,ki) + tmpanl(:,:,ki) = tvanl(:,:,ki)/(1. + fv*qanl(:,:,ki)) + end do + inc3d = tmpanl - tmp + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('T_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, tvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! delz increment + inc3d(:,:,:) = zero + if (has_var(dsfg,'delz')) then + allocate(delzb(nlons*nlats)) + call read_vardata(dsfg,'pressfc',values_2d,errcode=iret) + if (allocated(psges)) deallocate(psges) + allocate(psges(nlons*nlats)) + psges = reshape(values_2d,(/nlons*nlats/)) + vg = psges + (psinc*100_r_kind) + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug=(rd/grav)*reshape(tvanl(:,:,ki),(/nlons*nlats/)) + ! ps in Pa here, need to multiply ak by 100. + ug=ug*log((100_r_kind*ak(krev)+bk(krev)*vg)/(100_r_kind*ak(krev+1)+bk(krev+1)*vg)) + ! ug is hydrostatic analysis delz inferred from analysis ps,Tv + ! delzb is hydrostatic background delz inferred from background ps,Tv + delzb=(rd/grav)*reshape(tv(:,:,ki),(/nlons*nlats/)) + delzb=delzb*log((100_r_kind*ak(krev)+bk(krev)*psges)/(100_r_kind*ak(krev+1)+bk(krev+1)*psges)) + inc3d(:,:,ki)=reshape(delzb-ug,(/nlons,nlats/)) + end do + end if + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('delz_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, delzvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! o3mr increment + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (oz_ind > 0) then + call copyfromgrdin(grdin(:,levels(oz_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + end do + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('o3mr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, o3varid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! liq wat increment + ! icmr increment + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug = zero + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) + end if + if (imp_physics == 11) then + work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c) + do i=1,nlons*nlats + work(i) = max(zero,work(i)) + work(i) = min(one,work(i)) + enddo + vg = ug * work ! cloud ice + ug = ug * (one - work) ! cloud water + inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) + endif + inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) + enddo + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) + end do + if (should_zero_increments_for('icmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + + ! deallocate things + deallocate(inc3d,inc3d2,inc3dout) + deallocate(tmp,tv,q,tmpanl,tvanl,qanl) + if (allocated(delzb)) deallocate(delzb) + if (allocated(psges)) deallocate(psges) + end do backgroundloop ! loop over backgrounds to write out - end do ensmemloop ! loop over ens members to write out + ! remove the sub communicators + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + call mpi_comm_free(iocomms(mem_pe(nproc)), iret) + call mpi_barrier(mpi_comm_world, iret) + + return - contains + 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 subroutine writeincrement_pnc logical function checkfield(field,fields,nrec) result(hasfield) use nemsio_module, only: nemsio_charkind @@ -1485,4 +4127,36 @@ logical function checkfield(field,fields,nrec) result(hasfield) enddo end function checkfield + subroutine nccheck_incr(status) + use netcdf + integer, intent (in ) :: status + if (status /= nf90_noerr) then + print *, "fv3_increment netCDF error ", trim(nf90_strerror(status)) + call stop2(999) + end if + end subroutine nccheck_incr + + !! Is this variable in incvars_to_zero? + logical function should_zero_increments_for(check_var) + use params, only : incvars_to_zero + + character(len=*), intent(in) :: check_var !! Variable to search for + + ! Local variables + + character(len=12) :: varname ! temporary string for storing variable names + integer :: i ! incvars_to_zero loop index + + should_zero_increments_for=.false. + + zeros_loop: do i=1,size(incvars_to_zero) + 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 + end module gridio diff --git a/src/enkf/gridio_wrf.f90 b/src/enkf/gridio_wrf.f90 index 3a2e1b372d..6eabcd256f 100644 --- a/src/enkf/gridio_wrf.f90 +++ b/src/enkf/gridio_wrf.f90 @@ -52,7 +52,7 @@ module gridio 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) + subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,filesfcprefixes,reducedgrid,vargrid,qsat) use constants, only: max_varname_length implicit none integer, intent(in) :: nanal1,nanal2, n2d, n3d, ndim, ntimes @@ -60,15 +60,16 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,f 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 + character(len=120), dimension(7), intent(in) :: filesfcprefixes logical, intent(in) :: reducedgrid real(r_single), dimension(npts,ndim,ntimes), intent(out) :: vargrid real(r_double), dimension(npts,nlevs,ntimes), intent(out) :: qsat if (arw) then - call readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,vargrid,qsat) + call readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,filesfcprefixes,vargrid,qsat) else if (nmm) then - call readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,vargrid,qsat) + call readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,filesfcprefixes,vargrid,qsat) endif end subroutine readgriddata @@ -76,7 +77,7 @@ end subroutine readgriddata !======================================================================== ! readgriddata_arw.f90: read WRF-ARW state or control vector !------------------------------------------------------------------------- - subroutine readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,vargrid,qsat) + subroutine readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,filesfcprefixes,vargrid,qsat) use constants !====================================================================== @@ -86,6 +87,7 @@ subroutine readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntim 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 + character(len=120), dimension(7), intent(in) :: filesfcprefixes ! Define variables returned by subroutine real(r_single), dimension(npts,ndim,ntimes,nanal2-nanal1+1), intent(out) :: vargrid @@ -93,6 +95,7 @@ subroutine readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntim ! Define local variables character(len=500) :: filename + character(len=500) :: filenamesfc character(len=7) :: charnanal logical :: ice @@ -157,6 +160,7 @@ subroutine readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntim charnanal = 'ensmean' endif filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) + filenamesfc = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal) !---------------------------------------------------------------------- ! read u-component @@ -429,7 +433,7 @@ end subroutine readgriddata_arw ! readgriddata_nmm.f90: read WRF-NMM state or control vector !------------------------------------------------------------------------- - subroutine readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,vargrid,qsat) + subroutine readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,filesfcprefixes,vargrid,qsat) use constants !====================================================================== ! Define variables passed to subroutine @@ -438,6 +442,7 @@ subroutine readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntim 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 + character(len=120), dimension(7), intent(in) :: filesfcprefixes ! Define variables returned by subroutine real(r_single), dimension(npts,ndim,ntimes,nanal2-nanal1+1), intent(out) :: vargrid @@ -454,6 +459,7 @@ subroutine readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntim character(len=12) :: varstrname character(len=500) :: filename + character(len=500) :: filenamesfc character(len=7) :: charnanal ! Define counting variables @@ -496,6 +502,7 @@ subroutine readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntim charnanal = 'ensmean' endif filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) + filenamesfc = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal) !---------------------------------------------------------------------- ! read u-component diff --git a/src/enkf/inflation.f90 b/src/enkf/inflation.f90 index 119aa4446e..ca51c8a898 100644 --- a/src/enkf/inflation.f90 +++ b/src/enkf/inflation.f90 @@ -62,7 +62,11 @@ module inflation ! !$$$ -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max,mpi_realkind,& + mpi_min + use params, only: analpertwtnh,analpertwtsh,analpertwttr,nanals,nlevs,& analpertwtnh_rtpp,analpertwtsh_rtpp,analpertwttr_rtpp,& latbound, delat, datapath, covinflatemax, save_inflation, & diff --git a/src/enkf/letkf.F90 b/src/enkf/letkf.f90 similarity index 87% rename from src/enkf/letkf.F90 rename to src/enkf/letkf.f90 index 0689409d35..0f04739392 100644 --- a/src/enkf/letkf.F90 +++ b/src/enkf/letkf.f90 @@ -30,8 +30,8 @@ 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. If the code is compiled with -! -DMPI3, a single copy of the observation space ensemble is stored on each +! process. To reduce the overall memory footprint +! a single copy of the observation space ensemble is stored on each ! compute node and shared among processors. ! ! The parameter nobsl_max controls @@ -86,7 +86,12 @@ module letkf ! !$$$ -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max,mpi_realkind,& + mpi_min,numproc_shm,mpi_comm_shmem,mpi_info_null,nproc_shm,& + mpi_comm_shmemroot,mpi_mode_nocheck,mpi_lock_exclusive,& + mpi_address_kind use, intrinsic :: iso_c_binding use omp_lib, only: omp_get_num_threads,omp_get_thread_num use covlocal, only: taper, latval @@ -152,17 +157,6 @@ subroutine letkf_update() ! kdtree stuff type(kdtree2_result),dimension(:),allocatable :: sresults 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(:,:) :: 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, 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 @@ -182,106 +176,12 @@ subroutine letkf_update() 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. -! shared window size will be zero except on root task of -! 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 (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 - call MPI_Win_lock(MPI_LOCK_EXCLUSIVE,0,MPI_MODE_NOCHECK,shm_win,ierr) - call c_f_pointer(anal_ob_cp, anal_ob_fp, [nanals, nobstot]) - ! bcast entire obs prior ensemble from root task - ! to a single task on each node, assign to shared memory window. - ! send one ensemble member at a time. - allocate(buffer(nobstot)) - do nanal=1,nanals - if (nproc == 0) buffer(1:nobstot) = anal_ob(nanal,1:nobstot) - if (nproc_shm == 0) then - call mpi_bcast(buffer,nobstot,mpi_real4,0,mpi_comm_shmemroot,ierr) - anal_ob_fp(nanal,1:nobstot) = buffer(1:nobstot) - end if - end do - if (neigv > 0) then - call MPI_Win_lock(MPI_LOCK_EXCLUSIVE,0,MPI_MODE_NOCHECK,shm_win2,ierr) - 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) - 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 (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. -call mpi_barrier(mpi_comm_world, ierr) -! associate fortran pointer with c pointer to shared memory -! 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 (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 -! broadcast observation prior ensemble from root one ensemble member at a time. -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 (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) anal_ob_modens(nanal,1:nobstot) = buffer(1:nobstot) - end do -endif -deallocate(buffer) -#endif -t2 = mpi_wtime() -if (nproc .eq. 0) print *,'time to broadcast ob prior ensemble = ',t2-t1 - if (nproc .eq. 0 .and. .not. deterministic) then print *,'perturbed obs LETKF' endif @@ -301,10 +201,6 @@ subroutine letkf_update() print *,'warning - perturbed obs not used in LETKF (deterministic=F ignored)' endif -! 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() - nrej=0 ! reset ob error to account for gross errors if (varqc .and. lupd_obspace_serial) then @@ -514,24 +410,12 @@ subroutine letkf_update() do nob=1,nobsl2 nf=oindex(nob) if (neigv > 0) then -#ifdef MPI3 - hxens(1:nens,nob)=anal_ob_modens_fp(1:nens,nf) -#else hxens(1:nens,nob)=anal_ob_modens(1:nens,nf) -#endif else -#ifdef MPI3 - hxens(1:nens,nob)=anal_ob_fp(1:nens,nf) -#else hxens(1:nens,nob)=anal_ob(1:nens,nf) -#endif endif obens(1:nanals,nob) = & -#ifdef MPI3 - anal_ob_fp(1:nanals,nf) -#else anal_ob(1:nanals,nf) -#endif rdiag(nob)=one/oberrvaruse(nf) dep(nob)=ob(nf)-ensmean_ob(nf) end do @@ -650,18 +534,6 @@ subroutine letkf_update() 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 (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 (nproc .ne. 0 .and. allocated(anal_ob_modens)) deallocate(anal_ob_modens) if (allocated(ens_tmp)) deallocate(ens_tmp) return @@ -893,7 +765,7 @@ subroutine letkf_core(nobsl,hxens,hxens_orig,dep,& ! 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 (getkf) then ! use Gain formulation for LETKF weights if (denkf) then ! use Pa = C (Gamma + I)**-1 C^T (already computed) diff --git a/src/enkf/loadbal.f90 b/src/enkf/loadbal.f90 index e146c7a21b..60e7df8111 100644 --- a/src/enkf/loadbal.f90 +++ b/src/enkf/loadbal.f90 @@ -99,10 +99,13 @@ module loadbal ! !$$$ -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max 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 + neigv, corrlengthnh, corrlengthsh, corrlengthtr, lupd_obspace_serial,letkf_bruteforce_search +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 @@ -150,7 +153,7 @@ subroutine load_balance() if (letkf_flag) then ! used for finding nearest obs to grid point in LETKF. ! results are sorted by distance. - if (nobstot >= 3) then + if (nobstot >= 3 .and. .not. letkf_bruteforce_search) then kdtree_obs2 => kdtree2_create(obloc,sort=.true.,rearrange=.true.) endif endif @@ -294,68 +297,19 @@ subroutine load_balance() print *,'min/max number of obs per proc = ',nobs_min,nobs_max print *,'time to do ob space decomp = ',mpi_wtime()-t1 end if - ! for serial enkf, send out observation priors to be updated on each processor. + ! for serial enkf, create observation priors to be updated on each processor. allocate(anal_obchunk_prior(nanals,nobs_max)) - if(nproc == 0) then - print *,'sending out observation prior ensemble perts from root ...' - totsize = nobstot - totsize = totsize*nanals - print *,'nobstot*nanals',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_prior(1:nanals,nob1) = anal_ob(1:nanals,nob2) - end do - call mpi_send(anal_obchunk_prior,nobs_max*nanals,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_prior(1:nanals,nob1) = anal_ob(1:nanals,nob2) - end do - ! now we don't need anal_ob anymore for serial EnKF. - if (.not. lupd_obspace_serial) deallocate(anal_ob) - else - ! recv one large message on each task. - call mpi_recv(anal_obchunk_prior,nobs_max*nanals,mpi_real4,0, & - 1,mpi_comm_world,mpi_status,ierr) - end if + do nob1=1,numobsperproc(nproc+1) + nob2 = indxproc_obs(nproc+1,nob1) + anal_obchunk_prior(1:nanals,nob1) = anal_ob(1:nanals,nob2) + end do 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 + do nob1=1,numobsperproc(nproc+1) + nob2 = indxproc_obs(nproc+1,nob1) + anal_obchunk_modens_prior(1:nanals*neigv,nob1) = anal_ob_modens(1:nanals*neigv,nob2) + end do endif - call mpi_barrier(mpi_comm_world, ierr) if(nproc == 0) print *,'... took ',mpi_wtime()-t1,' secs' ! these arrays only needed for serial filter ! nob1 is the index of the obs to be processed on this rank diff --git a/src/enkf/mpi_readobs.f90 b/src/enkf/mpi_readobs.f90 index a18cc0e1d8..420ebe3227 100644 --- a/src/enkf/mpi_readobs.f90 +++ b/src/enkf/mpi_readobs.f90 @@ -32,13 +32,19 @@ module mpi_readobs ! !$$$ -use kinds, only: r_kind, r_single, i_kind +use kinds, only: r_double,i_kind,r_kind,r_single,num_bytes_for_r_single use params, only: ntasks_io, nanals_per_iotask, nanal1, nanal2 use radinfo, only: npred use readconvobs use readsatobs use readozobs -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max,mpi_realkind,& + mpi_min,numproc_shm,mpi_comm_shmem,mpi_info_null,nproc_shm,& + mpi_comm_shmemroot,mpi_mode_nocheck,mpi_lock_exclusive,& + mpi_address_kind +use, intrinsic :: iso_c_binding implicit none @@ -52,7 +58,8 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to sprd_ob, ensmean_ob, ensmean_obbc, ob, & oberr, oblon, oblat, obpress, & obtime, oberrorig, obcode, obtype, & - biaspreds, diagused, anal_ob, anal_ob_modens, indxsat, nanals, neigv) + biaspreds, diagused, anal_ob, anal_ob_modens, anal_ob_cp, anal_ob_modens_cp, & + shm_win, shm_win2, indxsat, nanals, neigv) character*500, intent(in) :: obspath character*10, intent(in) :: datestring character(len=10) :: id,id2 @@ -60,17 +67,23 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to 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 + ! pointers used for MPI-3 shared memory manipulations. + real(r_single), pointer, dimension(:,:) :: anal_ob, anal_ob_modens + type(c_ptr) anal_ob_cp, anal_ob_modens_cp + integer shm_win, shm_win2 real(r_single), allocatable, dimension(:,:) :: biaspreds - 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, neig, nens1, nens2, na, nmem,& - np, nobs_conv, nobs_oz, nobs_sat, nobs_tot, nanal, nanalo + integer(i_kind) nob, ierr, iozproc, isatproc, nens1, nens2, na, nmem,& + nens, nobs_conv, nobs_oz, nobs_sat, nobs_tot, nanal integer(i_kind) :: nobs_convdiag, nobs_ozdiag, nobs_satdiag, nobs_totdiag integer(i_kind), intent(in) :: nanals, neigv + integer(MPI_ADDRESS_KIND) :: win_size, nsize, nsize2, win_size2 + integer(MPI_ADDRESS_KIND) :: segment_size, disp_unit + iozproc=max(0,min(1,numproc-1)) isatproc=max(0,min(2,numproc-2)) ! get total number of conventional and sat obs for ensmean. @@ -88,15 +101,13 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to 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 (neigv > 0) then + nens = nanals*neigv ! modulated ensemble size + else + nens = nanals + endif ! 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(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),& @@ -109,6 +120,43 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to call stop2(11) end if +! setup shared memory segment on each node that points to +! observation prior ensemble. +! shared window size will be zero except on root task of +! shared memory group on each node. + disp_unit = int(num_bytes_for_r_single,kind=MPI_ADDRESS_KIND) ! anal_ob is r_single + nsize = int(nobs_tot,kind=MPI_ADDRESS_KIND)*int(nanals,kind=MPI_ADDRESS_KIND) + nsize2 = int(nobs_tot,kind=MPI_ADDRESS_KIND)*int(nanals,kind=MPI_ADDRESS_KIND)*int(neigv,kind=MPI_ADDRESS_KIND) + if (nproc_shm == 0) then + win_size = nsize*disp_unit + win_size2 = nsize2*disp_unit + if (win_size2 < 0) then + print *,'win_size2 = ',win_size2 + print *,'problem with shared window size, stopping!' + call stop2(11) + endif + 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 (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 + ! associate fortran pointer with c pointer to shared memory + ! 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, [nanals, nobs_tot]) + ! initialize shared memory window. + anal_ob=0 + 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, [nens, nobs_tot]) + anal_ob_modens=0 + endif + ! read ensemble mean and every ensemble member if (nproc <= ntasks_io-1) then nens1 = nanal1(nproc); nens2 = nanal2(nproc) @@ -121,6 +169,8 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to nmem = nmem + 1 ! nmem only used if lobsdiag_forenkf=T id = 'ensmean' id2 = id + mem_ob=0 + if (neigv > 0) mem_ob_modens=0 ! if nanal>nanals, ens member data not read (only ens mean) if (nanal <= nanals) then write(id2,'(a3,(i3.3))') 'mem',nanal @@ -181,86 +231,85 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to id,nanal,nmem) end if ! read obs. -! 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. -! if (nproc == 0) then -! t1 = mpi_wtime() -! allocate(anal_obtmp(nobs_tot,nanals)) -! endif -! 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 -! anal_ob = transpose(anal_obtmp); deallocate(anal_obtmp) -! t2 = mpi_wtime() -! print *,'time to create ob prior ensemble on root = ',t2-t1 -! endif -! endif - -! 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. +! populate obs prior ensemble shared array pointer on each io task. if (nproc <= ntasks_io-1) then - if (nproc == 0) then - t1 = mpi_wtime() - 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(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(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 ! io task + anal_ob(nmem+nproc*nanals_per_iotask,:) = mem_ob(:) + if (neigv > 0) then + na = nmem+nproc*nanals_per_iotask + anal_ob_modens(neigv*(na-1)+1:neigv*na,:) = mem_ob_modens(:,:) + endif + endif enddo ! nanal loop (loop over ens members on each task) + ! need this to prevent race condition on shared memory window + call mpi_barrier(mpi_comm_world,ierr) + +! obs prior ensemble now defined on root task, bcast to other tasks. + if (nproc == 0) print *,'broadcast ob prior ensemble' + if (nproc == 0) t1 = mpi_wtime() +! exchange obs prior ensemble members across all tasks to fully populate shared +! memory array pointer on each node. + if (nproc_shm == 0) then + call mpi_allreduce(mpi_in_place,anal_ob,nanals*nobs_tot,mpi_real4,mpi_sum,mpi_comm_shmemroot,ierr) + !print *,nproc,'min/max anal_ob',minval(anal_ob),maxval(anal_ob) + if (neigv > 0) then + mem_ob_modens = 0. + do na=1,nanals + mem_ob_modens(:,:) = anal_ob_modens(neigv*(na-1)+1:neigv*na,:) + call mpi_allreduce(mpi_in_place,mem_ob_modens,neigv*nobs_tot,mpi_real4,mpi_sum,mpi_comm_shmemroot,ierr) + anal_ob_modens(neigv*(na-1)+1:neigv*na,:) = mem_ob_modens(:,:) + enddo + endif + endif + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time to broadcast ob prior ensemble = ',t2-t1 + endif + if (allocated(mem_ob)) deallocate(mem_ob) + if (allocated(mem_ob_modens)) deallocate(mem_ob_modens) + call mpi_barrier(mpi_comm_world,ierr) + !print *,nproc,'min/max anal_ob',minval(anal_ob),maxval(anal_ob) ! 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) + analsi=1._r_single/float(nanals) + analsim1=1._r_single/float(nanals-1) !$omp parallel do private(nob) - do nob=1,nobs_tot - ensmean_ob(nob) = sum(anal_ob(:,nob))*analsi + do nob=1,nobs_tot + ensmean_obbc(nob) = sum(anal_ob(:,nob))*analsi + enddo +!$omp end parallel do + if (nproc_shm == 0) then +!$omp parallel do private(nob) + do nob=1,nobs_tot ! 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) +! ensmean_obbc is biascorrected ensemble mean (anal_ob is ens pert) + anal_ob(:,nob) = anal_ob(:,nob)-ensmean_obbc(nob) + enddo +!$omp end parallel do + if (neigv > 0) then +!$omp parallel do private(nob) + do nob=1,nobs_tot + anal_ob_modens(:,nob) = anal_ob_modens(:,nob)-ensmean_obbc(nob) + enddo +!$omp end parallel do + endif + endif + call mpi_barrier(mpi_comm_world,ierr) +!$omp parallel do private(nob) + do nob=1,nobs_tot ! compute sprd - sprd_ob(nob) = sum(anal_ob(:,nob)**2)*analsim1 + sprd_ob(nob) = sum(anal_ob(:,nob)**2)*analsim1 + enddo +!$omp end parallel do ! 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 + if (neigv > 0) then +!$omp parallel do private(nob) + do nob=1,nobs_tot + sprd_ob(nob) = sum(anal_ob_modens(:,nob)**2)*analsim1 enddo !$omp end parallel do + endif + if (nproc == 0) then 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)) @@ -268,26 +317,12 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to 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), & + print *, nob, ' sat spread: ', sprd_ob(nob), ', ensmean_ob: ', ensmean_obbc(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) - if (nproc == 0) then - t2 = mpi_wtime() - print *,'time to broadcast ob prior ensemble mean and spread = ',t2-t1 - endif - - end subroutine mpi_getobs end module mpi_readobs diff --git a/src/enkf/mpisetup.F90 b/src/enkf/mpisetup.f90 similarity index 99% rename from src/enkf/mpisetup.F90 rename to src/enkf/mpisetup.f90 index 2d632d72e2..9b2841e6d9 100644 --- a/src/enkf/mpisetup.F90 +++ b/src/enkf/mpisetup.f90 @@ -41,10 +41,8 @@ module mpisetup subroutine mpi_initialize() use mpimod, only : mpi_comm_world,npe,mype integer ierr -#ifdef MPI3 integer nuse,new_group,old_group,nshmemroot,np integer, dimension(:), allocatable :: useprocs, itasks -#endif call mpi_init(ierr) ! nproc is process number, numproc is total number of processes. call mpi_comm_rank(mpi_comm_world,nproc,ierr) @@ -61,7 +59,6 @@ subroutine mpi_initialize() call mpi_cleanup() endif -#ifdef MPI3 ! all the rest below only used for LETKF... ! split into shared memory sub communicators. @@ -93,7 +90,6 @@ subroutine mpi_initialize() deallocate(useprocs) call MPI_COMM_CREATE(MPI_COMM_WORLD,new_group,mpi_comm_shmemroot,ierr) !print *,'ierr from mpi_comm_create',ierr,mpi_comm_shmemroot -#endif end subroutine mpi_initialize diff --git a/src/enkf/observer_gfs.f90 b/src/enkf/observer_gfs.f90 index 8d219f2e8b..983b25f959 100644 --- a/src/enkf/observer_gfs.f90 +++ b/src/enkf/observer_gfs.f90 @@ -127,7 +127,7 @@ subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, & end subroutine setup_linhx -subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & +subroutine calc_linhx(hx, dens, dhx_dx, hxpert, hx_ens, & ix, delx, ixp, delxp, iy, dely, iyp, delyp, & it, delt, itp, deltp) !$$$ subprogram documentation block @@ -149,6 +149,8 @@ subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & ! ! output argument list: ! hx_ens: observation prior ensemble perturbation +! hxpert: ens pert profile that multiplies dhx_dx to yield hx_ens (in +! compressed format - temporally and horizontally interpolated) ! ! attributes: ! language: f95 @@ -159,7 +161,7 @@ subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & use gridinfo, only: npts use statevec, only: nsdim use constants, only: zero,one - use sparsearr, only: sparr + use sparsearr, only: sparr, raggedarr use mpisetup implicit none @@ -169,32 +171,30 @@ subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & 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 + type(raggedarr) ,intent(inout) :: hxpert ! interpolated background real(r_single) ,intent( out) :: hx_ens ! H (x_ens) - integer(i_kind) i,j,k + integer(i_kind) i,j ! 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) + hxpert%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) + hx_ens = hx_ens + dhx_dx%val(i) * hxpert%val(i) 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) +subroutine calc_linhx_modens(hx, dhx_dx, hxpert, hx_ens, vscale) !$$$ subprogram documentation block ! . . . . ! subprogram: calc_linhx @@ -203,59 +203,41 @@ subroutine calc_linhx_modens(hx, dens, dhx_dx, hx_ens, & ! abstract: ! ! program history log: -! 2016-11-29 shlyaeva +! 2016-11-29 shlyaeva, initial version +! 2019-12-09 whitaker, optimizations ! ! 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. +! hxpert: 'unmodulated' ens pert profile that multiplies dhx_dx +! vscale: vertical scaling from vertical localization eigenvectors used +! to generate modulated ensemble. ! ! 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 sparsearr, only: sparr, raggedarr 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 + type(raggedarr) ,intent(in ) :: hxpert ! interpolated background 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 + integer(i_kind) i - ! interpolate state horizontally and in time and do dot product with dHx/dx profile - ! saves from calculating interpolated x_ens for each state variable + ! calculate modulated ensemble in ob space 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) + hx_ens(:) = hx_ens(:) + dhx_dx%val(i) * vscale(:,kindx(dhx_dx%ind(i))) * hxpert%val(i) enddo return diff --git a/src/enkf/observer_reg.f90 b/src/enkf/observer_reg.f90 index 687b8b9eab..51a9c85d66 100644 --- a/src/enkf/observer_reg.f90 +++ b/src/enkf/observer_reg.f90 @@ -133,7 +133,7 @@ subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, & end subroutine setup_linhx -subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & +subroutine calc_linhx(hx, dens, dhx_dx, hxpert, hx_ens, & ix, delx, ixp, delxp, iy, dely, iyp, delyp, & it, delt, itp, deltp) !$$$ subprogram documentation block @@ -165,7 +165,7 @@ subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & use gridinfo, only: npts, latsgrd, lonsgrd use statevec, only: nsdim use constants, only: zero,one,pi - use sparsearr, only: sparr + use sparsearr, only: sparr, raggedarr use mpisetup implicit none @@ -175,6 +175,7 @@ subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & 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 + type(raggedarr) ,intent(inout) :: hxpert ! interpolated background real(r_single) ,intent( out) :: hx_ens ! H (x_ens) integer(i_kind) i,j,k @@ -184,23 +185,21 @@ subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & 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) + hxpert%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) + hx_ens = hx_ens + dhx_dx%val(i) * hxpert%val(i) 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) +subroutine calc_linhx_modens(hx, dhx_dx, hxpert, hx_ens, vscale) !$$$ subprogram documentation block ! . . . . ! subprogram: calc_linhx @@ -209,59 +208,41 @@ subroutine calc_linhx_modens(hx, dens, dhx_dx, hx_ens, & ! abstract: ! ! program history log: -! 2016-11-29 shlyaeva +! 2016-11-29 shlyaeva, initial version +! 2019-12-09 whitaker, optimizations ! ! 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. +! hxpert: 'unmodulated' ens pert profile that multiplies dhx_dx +! vscale: vertical scaling from vertical localization eigenvectors used +! to generate modulated ensemble. ! ! 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 sparsearr, only: sparr, raggedarr 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 + type(raggedarr) ,intent(in ) :: hxpert ! interpolated background 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 + integer(i_kind) i - ! interpolate state horizontally and in time and do dot product with dHx/dx profile - ! saves from calculating interpolated x_ens for each state variable + ! calculate modulated ensemble in ob space 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) + hx_ens(:) = hx_ens(:) + dhx_dx%val(i) * vscale(:,kindx(dhx_dx%ind(i))) * hxpert%val(i) enddo return diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index 9757a58a71..89688eb4cc 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -24,7 +24,7 @@ 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 +! 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 @@ -71,8 +71,11 @@ 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 :: fgsfcfileprefixes character(len=120),dimension(7),public :: statefileprefixes +character(len=120),dimension(7),public :: statesfcfileprefixes character(len=120),dimension(7),public :: anlfileprefixes +character(len=120),dimension(7),public :: incfileprefixes ! analysis date string (YYYYMMDDHH) character(len=10), public :: datestring ! filesystem path to input files (first-guess, GSI diagnostic files). @@ -83,6 +86,7 @@ module params logical, public :: deterministic, sortinc, pseudo_rh, & varqc, huber, cliptracers, readin_localization logical, public :: lupp +logical, public :: cnvw_option integer(i_kind),public :: iassim_order,nlevs,nanals,numiter,& nlons,nlats,nbackgrounds,nstatefields,& nanals_per_iotask, ntasks_io @@ -125,6 +129,11 @@ module params ! matrix are read from a file called 'vlocal_eig.dat' ! (created by an external python utility). logical,public :: modelspace_vloc=.false. +! use correlated obs errors +! (implies letkf_flag=T, modelspace_vloc=T and lobsdiag_forenkf=T) +! if T, extra fields read from diag file and innovation stats +! are in transformed space (R**{-1/2}). +logical,public :: use_correlated_oberrs=.false. ! number of eigenvectors of vertical localization ! used. Zero if modelspace_vloc=.false., read from ! file 'vlocal_eig.dat' if modelspace_vloc=.true. @@ -156,14 +165,17 @@ module params logical,public :: univaroz = .true. logical,public :: regional = .false. logical,public :: use_gfs_nemsio = .false. +logical,public :: use_gfs_ncio = .false. logical,public :: arw = .false. logical,public :: nmm = .true. logical,public :: nmm_restart = .true. logical,public :: nmmb = .false. logical,public :: letkf_flag = .false. +! use brute force search in LETKF instead of kdtree +logical,public :: letkf_bruteforce_search=.false. ! next two are no longer used, instead they are inferred from anavinfo -logical,public :: massbal_adjust = .false. +logical,public :: massbal_adjust = .false. integer(i_kind),public :: nvars = -1 ! sort obs in LETKF in order of decreasing DFS @@ -194,7 +206,15 @@ module params 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 +logical,public ::l_pres_add_saved + +! for parallel netCDF +logical, public :: paranc = .false. +logical, public :: nccompress = .false. + +! for writing increments +logical,public :: write_fv3_incr = .false. +character(len=12),dimension(10),public :: incvars_to_zero='NONE' !just picking 10 arbitrarily namelist /nam_enkf/datestring,datapath,iassim_order,nvars,& covinflatemax,covinflatemin,deterministic,sortinc,& @@ -205,19 +225,22 @@ module params lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,& lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh,& - fgfileprefixes,anlfileprefixes,statefileprefixes,& + fgfileprefixes,fgsfcfileprefixes,anlfileprefixes, & + incfileprefixes, & + statefileprefixes,statesfcfileprefixes, & covl_minfact,covl_efold,lupd_obspace_serial,letkf_novlocal,& analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,& analpertwtnh_rtpp,analpertwtsh_rtpp,analpertwttr_rtpp,& - nlevs,nanals,saterrfact,univaroz,regional,use_gfs_nemsio,& + nlevs,nanals,saterrfact,univaroz,regional,use_gfs_nemsio,use_gfs_ncio,& paoverpb_thresh,latbound,delat,pseudo_rh,numiter,biasvar,& lupd_satbiasc,cliptracers,simple_partition,adp_anglebc,angord,& 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,& getkf,getkf_inflation,denkf,modelspace_vloc,dfs_sort,write_spread_diag,& - covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff,& - fso_cycling,fso_calculate,imp_physics,lupp,fv3_native + covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff,letkf_bruteforce_search,& + fso_cycling,fso_calculate,imp_physics,lupp,cnvw_option,use_correlated_oberrs,& + fv3_native, paranc, nccompress, write_fv3_incr,incvars_to_zero 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 @@ -237,7 +260,7 @@ subroutine read_namelist() ! corrlength (length for horizontal localization in km) ! 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 +! 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 @@ -252,7 +275,7 @@ subroutine read_namelist() ! **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 +! 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 @@ -360,7 +383,14 @@ subroutine read_namelist() ! Initialize first-guess and analysis file name prefixes. ! (blank means use default names) fgfileprefixes = ''; anlfileprefixes=''; statefileprefixes='' +fgsfcfileprefixes = ''; statesfcfileprefixes='' +incfileprefixes = '' + +! option for including convective clouds in the all-sky +cnvw_option=.false. + 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) @@ -408,7 +438,7 @@ subroutine read_namelist() 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). +! 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) @@ -481,6 +511,9 @@ subroutine read_namelist() nanal2(np) = np+1 enddo else + ! set paranc to false + if (nproc .eq. 0) print *,"nanals > numproc; forcing paranc=F" + paranc = .false. nanals_per_iotask = 1 do ntasks_io = nanals/nanals_per_iotask @@ -489,7 +522,7 @@ subroutine read_namelist() else nanals_per_iotask = nanals_per_iotask + 1 end if - end do + 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 @@ -541,6 +574,26 @@ subroutine read_namelist() print *,'univaroz is not supported in LETKF!' call stop2(19) end if + if (letkf_flag .and. .not. getkf .and. denkf) then + print *,'denkf only works when letkf_flag=T *and* getkf=T' + call stop2(19) + end if + if (lupd_satbiasc .and. letkf_flag) then + print *,'lupd_satbiasc not supported with LETKF' + call stop2(19) + endif + if (use_correlated_oberrs .and. .not. netcdf_diag) then + print *,'use_correlated_oberrs only works with netcdf_diag' + call stop2(19) + endif + if (use_correlated_oberrs .and. .not. letkf_novlocal) then + print *,'use_correlated_oberrs implies modelspace_vloc,lobsdiag_forenkf=T' + call stop2(19) + endif + if (use_correlated_oberrs .and. .not. lobsdiag_forenkf) then + print *,'use_correlated_oberrs implies letkf_flag,modelspace_vloc,lobsdiag_forenkf=T' + call stop2(19) + endif if ((obtimelnh < 1.e10 .or. obtimeltr < 1.e10 .or. obtimelsh < 1.e10) .and. & letkf_flag) then print *,'warning: no time localization in LETKF!' @@ -562,7 +615,7 @@ subroutine read_namelist() 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 @@ -581,6 +634,9 @@ subroutine read_namelist() fgfileprefixes(nbackgrounds+1)="sfg_"//datestring//"_fhr"//charfhr_anal(nbackgrounds+1)//"_" endif endif + if (trim(fgsfcfileprefixes(nbackgrounds+1)) .eq. "") then + fgsfcfileprefixes(nbackgrounds+1)="sfgsfc_"//datestring//"_fhr"//charfhr_anal(nbackgrounds+1)//"_" + end if nbackgrounds = nbackgrounds+1 end do @@ -600,6 +656,9 @@ subroutine read_namelist() statefileprefixes(nstatefields+1)="sfg_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_" endif endif + if (trim(statesfcfileprefixes(nstatefields+1)) .eq. "") then + statesfcfileprefixes(nstatefields+1)="sfgsfc_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_" + end if nstatefields = nstatefields+1 end do @@ -615,6 +674,7 @@ subroutine read_namelist() else ! global ! if (nbackgrounds > 1) then anlfileprefixes(nb)="sanl_"//datestring//"_fhr"//charfhr_anal(nb)//"_" + incfileprefixes(nb)="incr_"//datestring//"_fhr"//charfhr_anal(nb)//"_" ! else ! anlfileprefixes(nb)="sanl_"//datestring//"_" ! endif diff --git a/src/enkf/radbias.f90 b/src/enkf/radbias.f90 index efa62941a5..ddc05d0ff3 100644 --- a/src/enkf/radbias.f90 +++ b/src/enkf/radbias.f90 @@ -40,7 +40,9 @@ module radbias ! !$$$ -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max,mpi_realkind use kinds, only: r_kind,i_kind,r_double use radinfo, only: & npred,predx,nusis,nuchan,jpch_rad,adp_anglebc,varA,ostats,inew_rad,newpc4pred diff --git a/src/enkf/read_locinfo.f90 b/src/enkf/read_locinfo.f90 index 415cd0fb49..3e93ee46e9 100644 --- a/src/enkf/read_locinfo.f90 +++ b/src/enkf/read_locinfo.f90 @@ -8,7 +8,9 @@ subroutine read_locinfo() kdtree2_result, kdtree2_n_nearest use constants, only: zero, rearth use gridinfo, only: gridloc, logp - use mpisetup + use mpimod, only: mpi_comm_world + use mpisetup, only: mpi_real4,mpi_sum,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_real8,mpi_max,mpi_min logical lexist character(len=40) :: fname = 'hybens_info' real(r_kind) oblnp_indx(1) diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index 376be6a7b6..5b734e848f 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -31,7 +31,7 @@ module readconvobs use kinds, only: r_kind,i_kind,r_single,r_double use constants, only: one,zero,deg2rad -use params, only: npefiles, netcdf_diag +use params, only: npefiles, netcdf_diag, modelspace_vloc implicit none private @@ -360,8 +360,9 @@ subroutine get_num_convobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) 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 + abs(obmax) > 1.e9_r_kind) cycle + if (.not. modelspace_vloc .and. & + (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 @@ -446,7 +447,7 @@ 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 sparsearr, only: sparr, sparr2, new, delete, assignment(=), init_raggedarr, raggedarr use params, only: nanals, lobsdiag_forenkf, neigv, vlocal_evecs use statevec, only: state_d use mpisetup, only: nproc, mpi_wtime @@ -482,12 +483,15 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & character(len=4) pe_name character*500 obsfile, obsfile2 character(len=10) :: id2 + + type(sparr2) :: dhx_dx_read type(sparr) :: dhx_dx + type(raggedarr) :: hxpert character(len=3) :: obtype integer(i_kind) :: iunit, iunit2, ipe, itype - integer(i_kind) :: nobs, nobdiag, i, nob, nsdim + integer(i_kind) :: nobs, nobdiag, i, nob, nnz, nind real(r_kind) :: errorlimit,errorlimit2,error,errororig real(r_kind) :: obmax, pres real(r_kind) :: errorlimit2_obs,errorlimit2_bnd @@ -502,8 +506,11 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & 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 + integer(i_kind), allocatable, dimension (:,:) :: Observation_Operator_Jacobian_stind, v_Observation_Operator_Jacobian_stind + integer(i_kind), allocatable, dimension (:,:) :: Observation_Operator_Jacobian_endind, v_Observation_Operator_Jacobian_endind + real(r_single), allocatable, dimension (:,:) :: Observation_Operator_Jacobian_val, v_Observation_Operator_Jacobian_val + + integer(i_kind) :: ix, iy, it, ixp, iyp, itp, nprof 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 @@ -524,6 +531,7 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & rlat_prev = -1.e30; rlon_prev=-1.e30; rtim_prev = -1.e30 nobdiag = 0 x_used = 0 + nprof = 0 hx = zero @@ -592,15 +600,26 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & 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 + 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)) + if (obtype == ' uv') then + allocate(v_Observation_Operator_Jacobian_stind(nind, nobs)) + allocate(v_Observation_Operator_Jacobian_endind(nind, nobs)) + allocate(v_Observation_Operator_Jacobian_val(nnz, nobs)) + call nc_diag_read_get_var(iunit, 'u_Observation_Operator_Jacobian_stind', Observation_Operator_Jacobian_stind) + call nc_diag_read_get_var(iunit, 'u_Observation_Operator_Jacobian_endind', Observation_Operator_Jacobian_endind) + call nc_diag_read_get_var(iunit, 'u_Observation_Operator_Jacobian_val', Observation_Operator_Jacobian_val) + call nc_diag_read_get_var(iunit, 'v_Observation_Operator_Jacobian_stind', v_Observation_Operator_Jacobian_stind) + call nc_diag_read_get_var(iunit, 'v_Observation_Operator_Jacobian_endind', v_Observation_Operator_Jacobian_endind) + call nc_diag_read_get_var(iunit, 'v_Observation_Operator_Jacobian_val',v_Observation_Operator_Jacobian_val) + else + 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 endif @@ -664,8 +683,9 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & 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 + abs(obmax) > 1.e9_r_kind) cycle + if (.not. modelspace_vloc .and. & + (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 @@ -712,16 +732,14 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & 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 - + hx(nob) = Observation(i) - Obs_Minus_Forecast_adjusted2(i) ! run the linearized Hx else - dhx_dx = Observation_Operator_Jacobian(1:nsdim,i) - + 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 @@ -737,24 +755,22 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & call setup_linhx(rlat,rlon,rtim, & ix, delx, ixp, delxp, iy, dely, & iyp, delyp, it, delt, itp, deltp) + else + nprof = nprof + 1 endif - call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem),& - dhx_dx, hx(nob), & + call init_raggedarr(hxpert, dhx_dx%nnz) + call calc_linhx(hx_mean(nob), state_d(:,:,:,nmem),& + dhx_dx, hxpert, 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 + if (neigv>0) call calc_linhx_modens(hx_mean(nob),dhx_dx,hxpert,hx_modens(:,nob),vlocal_evecs) t2 = mpi_wtime() tsum = tsum + t2-t1 call delete(dhx_dx) + call delete(dhx_dx_read) endif ! normalize q by qsatges @@ -803,12 +819,16 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & if (nanal <= nanals) then ! read full Hx if (.not. lobsdiag_forenkf) then - hx(nob) = v_Observation(i) - v_Obs_Minus_Forecast_unadjusted2(i) + hx(nob) = v_Observation(i) - v_Obs_Minus_Forecast_adjusted2(i) ! run linearized Hx else t1 = mpi_wtime() - dhx_dx = v_Observation_Operator_Jacobian(1:nsdim,i) + call new(dhx_dx_read, nnz, nind) + dhx_dx_read%st_ind = v_Observation_Operator_Jacobian_stind(:,i) + dhx_dx_read%end_ind = v_Observation_Operator_Jacobian_endind(:,i) + dhx_dx_read%val = v_Observation_Operator_Jacobian_val(:,i) + dhx_dx = dhx_dx_read ! don't need this since we know ob location is the same? rlat = x_lat(nob)*deg2rad rlon = x_lon(nob)*deg2rad @@ -825,21 +845,17 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & 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), & + call init_raggedarr(hxpert, dhx_dx%nnz) + call calc_linhx(hx_mean(nob), state_d(:,:,:,nmem), & + dhx_dx, hxpert, 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 + if (neigv>0) call calc_linhx_modens(hx_mean(nob),dhx_dx,hxpert,hx_modens(:,nob),vlocal_evecs) t2 = mpi_wtime() tsum = tsum + t2-t1 call delete(dhx_dx) + call delete(dhx_dx_read) endif endif endif @@ -863,9 +879,13 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & endif if (lobsdiag_forenkf) then - deallocate(Observation_Operator_Jacobian) + deallocate(Observation_Operator_Jacobian_stind) + deallocate(Observation_Operator_Jacobian_endind) + deallocate(Observation_Operator_Jacobian_val) if (obtype == ' uv') then - deallocate(v_Observation_Operator_Jacobian) + deallocate(v_Observation_Operator_Jacobian_stind) + deallocate(v_Observation_Operator_Jacobian_endind) + deallocate(v_Observation_Operator_Jacobian_val) endif endif @@ -881,6 +901,7 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & enddo peloop ! ipe loop enddo obtypeloop + if (nanal == nanals) print *,'conv ob profiles, total obs',nprof,nob 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 @@ -903,11 +924,13 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & use statevec, only: state_d use mpisetup, only: nproc, mpi_wtime use observer_enkf, only: calc_linhx,calc_linhx_modens,setup_linhx + use sparsearr, only: sparr, init_raggedarr, raggedarr implicit none character*500, intent(in) :: obspath character*10, intent(in) :: datestring integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + type(raggedarr) :: hxpert real(r_single), dimension(nobs_max), intent(out) :: hx_mean real(r_single), dimension(nobs_max), intent(out) :: hx_mean_nobc @@ -1080,8 +1103,9 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & endif 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 + abs(obmax) > 1.e9_r_kind) cycle + if (.not. modelspace_vloc .and. & + (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 @@ -1148,10 +1172,6 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & 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 @@ -1177,18 +1197,13 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & 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), & + call init_raggedarr(hxpert, dhx_dx%nnz) + call calc_linhx(hx_mean(nob), state_d(:,:,:,nmem), & + dhx_dx, hxpert, 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 + if (neigv>0) call calc_linhx_modens(hx_mean(nob),dhx_dx,hxpert,hx_modens(:,nob),vlocal_evecs) t2 = mpi_wtime() tsum = tsum + t2-t1 @@ -1244,7 +1259,7 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & if (nanal <= nanals) then ! read full Hx if (.not. lobsdiag_forenkf) then - hx(nob) = rdiagbuf(20,n)-rdiagbuf2(22,n) + hx(nob) = rdiagbuf(20,n)-rdiagbuf2(21,n) ! run linearized Hx else call readarray(dhx_dx_read, rdiagbuf(ind:nreal,n)) @@ -1267,18 +1282,13 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & 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, & + call init_raggedarr(hxpert, dhx_dx%nnz) + call calc_linhx(hx_mean(nob), state_d(:,:,:,nmem), & + dhx_dx, hxpert, 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 + if (neigv>0) call calc_linhx_modens(hx_mean(nob),dhx_dx,hxpert,hx_modens(:,nob),vlocal_evecs) t2 = mpi_wtime() tsum = tsum + t2-t1 @@ -1304,10 +1314,11 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & do n=1,ii 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 + rdiagbuf(6,n) > errorlimit2 .or. & + abs(rdiagbuf(7,n)) > 1.e9_r_kind )cycle + if(.not. modelspace_vloc .and. & + (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 diff --git a/src/enkf/readozobs.f90 b/src/enkf/readozobs.f90 index 0768dd9fbe..efd79b1c8c 100644 --- a/src/enkf/readozobs.f90 +++ b/src/enkf/readozobs.f90 @@ -27,7 +27,7 @@ module readozobs !$$$ use kinds, only: r_single,i_kind,r_kind,r_double -use params, only: nsats_oz,sattypes_oz,npefiles,netcdf_diag +use params, only: nsats_oz,sattypes_oz,npefiles,netcdf_diag,modelspace_vloc use constants, only: deg2rad, zero implicit none @@ -115,8 +115,9 @@ subroutine get_num_ozobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id) 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 + if (iouse(k) < 0) cycle + if (.not. modelspace_vloc .and. (pob(k) <= 0.001_r_kind .or. & + pob(k) > 1200._r_kind)) cycle do n=1,ii if (rdiagbuf(3,k,n) <= errorlimit .or. & rdiagbuf(3,k,n) >= errorlimit2 .or. & @@ -212,8 +213,9 @@ subroutine get_num_ozobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) 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 (Analysis_Use_Flag(i) < 0) cycle + if (.not. modelspace_vloc .and. (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 @@ -273,10 +275,12 @@ subroutine get_ozobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_me use statevec, only: state_d use mpisetup, only: mpi_wtime, nproc use observer_enkf, only: calc_linhx, calc_linhx_modens, setup_linhx + use sparsearr, only: sparr, init_raggedarr, raggedarr implicit none character*500, intent(in) :: obspath character*10, intent(in) :: datestring + type(raggedarr) :: hxpert integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag real(r_single), dimension(nobs_max), intent(out) :: hx_mean, hx_mean_nobc, hx @@ -435,8 +439,12 @@ subroutine get_ozobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_me 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) then + if (iouse(k) < 0) then + nobdiag = nobdiag + ii + cycle + endif + if (.not. modelspace_vloc .and.(pob(k) <= 0.001 .or. & + pob(k) > 1200._r_kind)) then nobdiag = nobdiag + ii cycle endif @@ -492,17 +500,13 @@ subroutine get_ozobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_me 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), & + call init_raggedarr(hxpert, dhx_dx%nnz) + call calc_linhx(hx_mean(nob), state_d(:,:,:,nmem), & + dhx_dx, hxpert, 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 + if (neigv>0) call calc_linhx_modens(hx_mean(nob),dhx_dx,hxpert,hx_modens(:,nob),vlocal_evecs) t2 = mpi_wtime() tsum = tsum + t2-t1 @@ -546,7 +550,7 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea 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 sparsearr,only:sparr, sparr2, readarray, new, delete, assignment(=), init_raggedarr, raggedarr use params,only: nanals, lobsdiag_forenkf, neigv, vlocal_evecs use statevec, only: state_d use mpisetup, only: mpi_wtime, nproc @@ -575,11 +579,14 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea character(len=8) :: id2 character(len=4) :: pe_name - integer(i_kind) :: nobs_curr, nob, nobdiag, i, nsat, ipe, nsdim + integer(i_kind) :: nobs_curr, nob, nobdiag, i, nsat, ipe, nnz, nind, nprof integer(i_kind) :: iunit, iunit2 real(r_double) t1,t2,tsum + + type(sparr2) :: dhx_dx_read type(sparr) :: dhx_dx + type(raggedarr) :: hxpert real(r_single), allocatable, dimension (:) :: Latitude, Longitude, Pressure, Time integer(i_kind), allocatable, dimension (:) :: Analysis_Use_Flag @@ -587,7 +594,9 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea 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 + 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 logical fexist logical twofiles, fexist2 @@ -613,6 +622,7 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea rlat_prev = -1.e30; rlon_prev=-1.e30; rtim_prev = -1.e30 nobdiag = 0 x_used = 0 + nprof = 0 hx = zero @@ -657,9 +667,14 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea 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) + 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_curr)) + allocate(Observation_Operator_Jacobian_endind(nind, nobs_curr)) + allocate(Observation_Operator_Jacobian_val(nnz, nobs_curr)) + 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) @@ -688,8 +703,9 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea 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 (Analysis_Use_Flag(i) < 0) cycle + if (.not. modelspace_vloc .and. (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 @@ -712,7 +728,11 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea hx(nob) = Observation(i) - Obs_Minus_Forecast_adjusted2(i) ! run linearized Hx else - dhx_dx = Observation_Operator_Jacobian(1:nsdim,i) + 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 @@ -728,22 +748,21 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea call setup_linhx(rlat,rlon,rtim, & ix, delx, ixp, delxp, iy, dely, & iyp, delyp, it, delt, itp, deltp) + else + nprof = nprof + 1 endif - call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & - dhx_dx, hx(nob), & + call init_raggedarr(hxpert, dhx_dx%nnz) + call calc_linhx(hx_mean(nob), state_d(:,:,:,nmem), & + dhx_dx, hxpert, 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 + if (neigv>0) call calc_linhx_modens(hx_mean(nob),dhx_dx,hxpert,hx_modens(:,nob),vlocal_evecs) t2 = mpi_wtime() tsum = tsum + t2-t1 call delete(dhx_dx) + call delete(dhx_dx_read) endif endif @@ -756,10 +775,13 @@ subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mea deallocate(Obs_Minus_Forecast_adjusted2) endif if (lobsdiag_forenkf) then - deallocate(Observation_Operator_Jacobian) + deallocate(Observation_Operator_Jacobian_stind) + deallocate(Observation_Operator_Jacobian_endind) + deallocate(Observation_Operator_Jacobian_val) endif enddo peloop ! ipe enddo ! satellite + if (nanal == nanals) print *,'oz obs profiles, total obs',nprof,nob if (nanal == nanals .and. lobsdiag_forenkf) print *, 'time in calc_linhx for oz obs on proc',nproc,' =',tsum if (nob /= nobs_max) then diff --git a/src/enkf/readsatobs.f90 b/src/enkf/readsatobs.f90 index 4f32a8855c..44923d2c38 100644 --- a/src/enkf/readsatobs.f90 +++ b/src/enkf/readsatobs.f90 @@ -34,7 +34,8 @@ module readsatobs 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, open_radiag, close_radiag -use params, only: nsats_rad, dsis, sattypes_rad, npefiles, netcdf_diag, lupd_satbiasc +use params, only: nsats_rad, dsis, sattypes_rad, npefiles, netcdf_diag, & + lupd_satbiasc, use_correlated_oberrs, modelspace_vloc implicit none @@ -149,9 +150,9 @@ subroutine get_num_satobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id) .or. data_chan0(n)%errinv > errorlimit2 & .or. indxsat == 0) cycle chan if (header_fix0%iextra > 0) then - if(data_extra0(1,n)%extra <= 0.001_r_kind .or. & - data_extra0(1,n)%extra > 1200._r_kind .or. & - abs(data_chan0(n)%tbobs) > 1.e9_r_kind) cycle chan + if(.not. modelspace_vloc .and. (data_extra0(1,n)%extra <= 0.001_r_kind .or. & + data_extra0(1,n)%extra > 1200._r_kind)) cycle chan + if(abs(data_chan0(n)%tbobs) > 1.e9_r_kind) cycle chan else if(abs(data_chan0(n)%tbobs) > 1.e9_r_kind) cycle chan endif @@ -268,9 +269,9 @@ subroutine get_num_satobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) 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 + if(.not. modelspace_vloc .and. (Pressure(i) <= 0.001_r_kind .or. & + Pressure(i) > 1200._r_kind)) cycle + if(abs(Observation(i)) > 1.e9_r_kind) cycle nkeep = nkeep + 1 enddo num_obs_tot = num_obs_tot + nkeep @@ -332,10 +333,12 @@ subroutine get_satobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_m 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, init_raggedarr, raggedarr implicit none character*500, intent(in) :: obspath character(len=10), intent(in) :: datestring + type(raggedarr) :: hxpert integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag @@ -495,9 +498,9 @@ subroutine get_satobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_m .or. data_chan(n)%errinv > errorlimit2 & .or. indxsat == 0) 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 + if(.not. modelspace_vloc .and. (data_extra(1,n)%extra <= 0.001_r_kind .or. & + data_extra(1,n)%extra > 1200._r_kind)) cycle chan + if(abs(data_chan(n)%tbobs) > 1.e9_r_kind) cycle chan else if(abs(data_chan(n)%tbobs) > 1.e9_r_kind) cycle chan endif @@ -523,7 +526,7 @@ subroutine get_satobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_m if (nanal <= nanals) then ! read full Hx if (.not. lobsdiag_forenkf) then - hx(nob) = x_obs(nob) - data_chan2(n)%omgnbc + hx(nob) = x_obs(nob) - data_chan2(n)%omgbc ! run linearized Hx else rlat = x_lat(nob)*deg2rad @@ -541,17 +544,13 @@ subroutine get_satobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_m 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), & + call init_raggedarr(hxpert, data_chan(n)%dhx_dx%nnz) + call calc_linhx(hx_mean(nob), state_d(:,:,:,nmem), & + data_chan(n)%dhx_dx, hxpert, 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 + if (neigv>0) call calc_linhx_modens(hx_mean(nob),data_chan(n)%dhx_dx,hxpert,hx_modens(:,nob),vlocal_evecs) t2 = mpi_wtime() tsum = tsum + t2-t1 endif @@ -644,7 +643,8 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me 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 + use sparsearr, only: sparr, assignment(=), delete, sparr2, new, & + init_raggedarr, raggedarr implicit none @@ -686,13 +686,17 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me type(sparr2) :: dhx_dx_read type(sparr) :: dhx_dx + type(raggedarr) :: hxpert 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 :: Pressure, QC_Flag, Inv_Error, Inv_Error_scaled, & + Observation, Observation_scaled 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 + real(r_single), dimension(:), allocatable :: Obs_Minus_Forecast_adjusted_scaled + real(r_single), dimension(:), allocatable :: Obs_Minus_Forecast_adjusted_scaled2 + real(r_single), dimension(:), allocatable :: Obs_Minus_Forecast_unadjusted, Obs_Minus_Forecast_adjusted2 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 @@ -701,7 +705,7 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me 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 + integer(i_kind) :: ix, iy, it, ixp, iyp, itp, nprof real(r_kind) :: delx, dely, delxp, delyp, delt, deltp ! make consistent with screenobs @@ -723,6 +727,7 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me rlat_prev = huge(rlat); rlon_prev=huge(rlon); rtim_prev = huge(rtim) nobdiag = 0 x_used = 0 + nprof = 0 do nsat=1,nsats_rad jpchstart=0 @@ -791,6 +796,13 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me 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 (use_correlated_oberrs) then + call nc_diag_read_get_var(iunit, 'Observation_scaled', Observation_scaled) + call nc_diag_read_get_var(iunit, 'Obs_Minus_Forecast_adjusted_scaled', & + Obs_Minus_Forecast_adjusted_scaled) + call nc_diag_read_get_var(iunit, 'Inverse_Observation_Error_scaled', & + Inv_Error_scaled) + endif 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), & @@ -854,9 +866,15 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me 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) - + if (use_correlated_oberrs) then + allocate(Obs_Minus_Forecast_adjusted_scaled2(nobs)) + call nc_diag_read_get_var(iunit2, 'Obs_Minus_Forecast_adjusted_scaled', & + Obs_Minus_Forecast_adjusted_scaled2) + else + allocate(Obs_Minus_Forecast_adjusted2(nobs)) + call nc_diag_read_get_var(iunit2, 'Obs_Minus_Forecast_adjusted', & + Obs_Minus_Forecast_adjusted2) + endif call nc_diag_read_close(obsfile2) end if @@ -867,9 +885,9 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me 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 + if (.not. modelspace_vloc .and. (Pressure(i) <= 0.001_r_kind .or. & + Pressure(i) > 1200._r_kind)) cycle + if (abs(Observation(i)) > 1.e9_r_kind) cycle nob = nob + 1 @@ -882,16 +900,22 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me 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) + if (use_correlated_oberrs) then + x_obs(nob) = Observation_scaled(i) + hx_mean(nob) = x_obs(nob) - Obs_Minus_Forecast_adjusted_scaled(i) + else + x_obs(nob) = Observation(i) + hx_mean(nob) = x_obs(nob) - Obs_Minus_Forecast_adjusted(i) + endif ! un-bias corrected Hx hx_mean_nobc(nob) = x_obs(nob) - Obs_Minus_Forecast_unadjusted(i) if (nanal <= nanals) then ! read full Hx + ! use_correlated_oberrs implies lobsdiag_forenkf if (.not. lobsdiag_forenkf) then - hx(nob) = x_obs(nob) - Obs_Minus_Forecast_unadjusted2(i) + hx(nob) = x_obs(nob) - Obs_Minus_Forecast_adjusted2(i) ! run linearized Hx else call new(dhx_dx_read, nnz, nind) @@ -899,6 +923,7 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me dhx_dx_read%end_ind = Observation_Operator_Jacobian_endind(:,i) dhx_dx_read%val = Observation_Operator_Jacobian_val(:,i) dhx_dx = dhx_dx_read + call init_raggedarr(hxpert, dhx_dx%nnz) t1 = mpi_wtime() rlat = x_lat(nob)*deg2rad rlon = x_lon(nob)*deg2rad @@ -914,18 +939,16 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me call setup_linhx(rlat,rlon,rtim, & ix, delx, ixp, delxp, iy, dely, & iyp, delyp, it, delt, itp, deltp) + else + nprof = nprof + 1 endif - call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & - dhx_dx, hx(nob), & + ! note: bias corrected mean added here, but removed later from hx + call calc_linhx(hx_mean(nob), state_d(:,:,:,nmem), & + dhx_dx, hxpert, 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 + if (neigv>0) call calc_linhx_modens(hx_mean(nob),dhx_dx,hxpert,hx_modens(:,nob),vlocal_evecs) t2 = mpi_wtime() tsum = tsum + t2-t1 call delete(dhx_dx) @@ -934,7 +957,11 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me endif x_errorig(nob) = error_variance(chind(i))**2 - x_err(nob) = (1._r_kind/Inv_Error(i))**2 + if (use_correlated_oberrs) then + x_err(nob) = (1._r_kind/Inv_Error_scaled(i))**2 + else + x_err(nob) = (1._r_kind/Inv_Error(i))**2 + endif x_press(nob) = Pressure(i) ! DTK: **NOTE** @@ -987,22 +1014,31 @@ subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_me deallocate(Pressure, QC_Flag, Inv_Error, Latitude, Longitude, Time, & Observation, chind, Obs_Minus_Forecast_unadjusted, & Obs_Minus_Forecast_adjusted) + if (use_correlated_oberrs) then + deallocate(Obs_Minus_Forecast_adjusted_scaled,Inv_Error_scaled,& + Observation_scaled) + endif 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 + if (twofiles) then + deallocate(Obs_Minus_Forecast_adjusted2) + if (use_correlated_oberrs) deallocate(Obs_Minus_Forecast_adjusted_scaled2) + endif + 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) print *,'radiance ob profiles, total obs',nprof,nob 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 diff --git a/src/enkf/smooth_gfs.f90 b/src/enkf/smooth_gfs.f90 index 2defe5bfd1..eec0aba122 100644 --- a/src/enkf/smooth_gfs.f90 +++ b/src/enkf/smooth_gfs.f90 @@ -4,7 +4,9 @@ module smooth_mod ! This version is for GFS, expects data to be on global gaussian grids (full or ! reduced). Isotropic spectral smoothing (gaussian) is used. -use mpisetup +use mpimod, only: mpi_comm_world +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc,& + mpi_integer,mpi_wtime,mpi_status,mpi_real8,mpi_max use params, only: nlons, nlats, reducedgrid, smoothparm use kinds, only: r_kind, i_kind, r_single use gridinfo, only: npts, ntrunc diff --git a/src/enkf/statevec.f90 b/src/enkf/statevec.f90 index 6c0726d81b..d1be91af3c 100644 --- a/src/enkf/statevec.f90 +++ b/src/enkf/statevec.f90 @@ -39,12 +39,14 @@ module statevec ! !$$$ -use gridio, only: readgriddata -use mpisetup +use gridio, only: readgriddata, readgriddata_pnc +use mpisetup, only: mpi_real4,mpi_sum,mpi_comm_io,mpi_in_place,numproc,nproc +use mpimod, only: mpi_comm_world 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 + ntasks_io,nanals_per_iotask,nanal1,nanal2, & + statesfcfileprefixes, paranc use kinds, only: r_kind, i_kind, r_double, r_single use mpeu_util, only: gettablesize, gettable, getindex use constants, only : max_varname_length @@ -183,12 +185,19 @@ subroutine read_state() end if ! read in whole state vector on i/o procs - keep in memory +allocate(state_d(npts,nsdim,nstatefields,nanals_per_iotask)) +allocate(qsat(npts,nlevs,nstatefields,nanals_per_iotask)) +if (paranc) then + call readgriddata_pnc(svars3d,svars2d,ns3d,ns2d,slevels,nsdim,nstatefields, & + statefileprefixes,statesfcfileprefixes,.false.,state_d,qsat) +end if + 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) + if ( .not. paranc) then + call readgriddata(nanal1(nproc),nanal2(nproc),svars3d,svars2d,ns3d,ns2d,slevels,nsdim,nstatefields, & + statefileprefixes,statesfcfileprefixes,.false.,state_d,qsat) + end if ! subtract the mean allocate(state_mean(npts)) @@ -204,7 +213,8 @@ subroutine read_state() enddo deallocate(state_mean) deallocate(qsat) - +else + deallocate(state_d) endif end subroutine read_state diff --git a/src/fv3gfs_ncio/CMakeLists.txt b/src/fv3gfs_ncio/CMakeLists.txt new file mode 100644 index 0000000000..337a5378c8 --- /dev/null +++ b/src/fv3gfs_ncio/CMakeLists.txt @@ -0,0 +1,10 @@ +cmake_minimum_required(VERSION 2.8) +if(BUILD_FV3GFS_NCIO) + set(Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") + # NetCDF-4 library + include_directories( ${NETCDF_INCLUDES} ${FV3GFS_NCIO_INCS} ) + FILE(GLOB FV3GFS_NCIO_SRC ${CMAKE_CURRENT_SOURCE_DIR}/module_fv3gfs_ncio.f90 ) + set_source_files_properties( ${FV3GFS_NCIO_SRC} PROPERTIES COMPILE_FLAGS ${FV3GFS_NCIO_Fortran_FLAGS} ) + add_library(fv3gfs_ncio STATIC ${FV3GFS_NCIO_SRC}) +endif(BUILD_FV3GFS_NCIO) + diff --git a/src/fv3gfs_ncio/module_fv3gfs_ncio.f90 b/src/fv3gfs_ncio/module_fv3gfs_ncio.f90 new file mode 100644 index 0000000000..e7a38b63b0 --- /dev/null +++ b/src/fv3gfs_ncio/module_fv3gfs_ncio.f90 @@ -0,0 +1,1338 @@ +module module_fv3gfs_ncio +! module for reading/writing netcdf global lat/lon grid files output by FV3GFS. +! assumes netcdf classic data model, nf90_format_netcdf4_classic format. +! handles 32 and 64 bit real variables, 8, 16 and 32 bit integer +! variables and char variables. Variables can have up to 5 dimensions. +! jeff whitaker 201910 + + use netcdf + use mpi + + implicit none + private + + type Variable + integer varid ! netCDF variable ID + integer ndims ! number of dimensions + integer dtype ! netCDF data type + integer natts ! number of attributes + integer deflate_level ! compression level (if > 0) + logical shuffle ! shuffle filter? + logical hasunlim ! has an unlimited dim? + character(len=nf90_max_name) :: name ! variable name + integer, allocatable, dimension(:) :: dimids ! netCDF dimension IDs + ! indices into Dataset%dimensions for associated dimensions. + integer, allocatable, dimension(:) :: dimindxs + ! names of associated dimensions. + character(len=nf90_max_name), allocatable, dimension(:) :: dimnames + ! current dimension lengths (updated after every write_vardata call) + integer, allocatable, dimension(:) :: dimlens + integer, allocatable, dimension(:) :: chunksizes + end type Variable + type Dimension + integer dimid ! netCDF dimension ID + integer len ! dimension length (updated after every write_vardata call) + logical isunlimited ! unlimited? + character(len=nf90_max_name) :: name ! name of dimension + end type Dimension + type Dataset + integer :: ncid ! netCDF ID. + integer :: nvars ! number of variables in dataset + integer :: ndims ! number of dimensions in dataset + integer :: natts ! number of dataset (global) attributes + integer :: nunlimdim ! dimension ID for unlimited dimension + logical :: ishdf5 ! is underlying disk format HDF5? + logical :: isparallel ! was file opened for parallel I/O? + character(len=500) filename ! netCDF filename + ! array of Variable instances + type(Variable), allocatable, dimension(:) :: variables + ! array of Dimension instances + type(Dimension), allocatable, dimension(:) :: dimensions + end type Dataset + + interface read_vardata + module procedure read_vardata_1d_r4, read_vardata_2d_r4, read_vardata_3d_r4,& + read_vardata_4d_r4, read_vardata_5d_r4, & + read_vardata_1d_r8, read_vardata_2d_r8, read_vardata_3d_r8,& + read_vardata_4d_r8, read_vardata_5d_r8, & + read_vardata_1d_int, read_vardata_2d_int, & + read_vardata_3d_int, read_vardata_4d_int, read_vardata_5d_int, & + read_vardata_1d_short, read_vardata_2d_short, & + read_vardata_3d_short, read_vardata_4d_short, read_vardata_5d_short , & + read_vardata_1d_byte, read_vardata_2d_byte, & + read_vardata_3d_byte, read_vardata_4d_byte, read_vardata_5d_byte, & + read_vardata_1d_char, read_vardata_2d_char, & + read_vardata_3d_char, read_vardata_4d_char, read_vardata_5d_char + end interface + + interface write_vardata + module procedure write_vardata_1d_r4, write_vardata_2d_r4, write_vardata_3d_r4,& + write_vardata_4d_r4, write_vardata_1d_r8, write_vardata_2d_r8, write_vardata_3d_r8,& + write_vardata_4d_r8, write_vardata_1d_int, write_vardata_2d_int, & + write_vardata_3d_int, write_vardata_4d_int, & + write_vardata_5d_int, write_vardata_5d_r4, write_vardata_5d_r8, & + write_vardata_1d_short, write_vardata_2d_short, write_vardata_3d_short, & + write_vardata_4d_short, write_vardata_5d_short, & + write_vardata_1d_byte, write_vardata_2d_byte, write_vardata_3d_byte, & + write_vardata_4d_byte, write_vardata_5d_byte, & + write_vardata_1d_char, write_vardata_2d_char, write_vardata_3d_char, & + write_vardata_4d_char, write_vardata_5d_char + end interface + + interface read_attribute + module procedure read_attribute_r4_scalar, read_attribute_int_scalar,& + read_attribute_r8_scalar, read_attribute_r4_1d,& + read_attribute_int_1d, read_attribute_r8_1d, read_attribute_char, & + read_attribute_short_scalar, read_attribute_short_1d, & + read_attribute_byte_scalar, read_attribute_byte_1d + end interface + + interface write_attribute + module procedure write_attribute_r4_scalar, write_attribute_int_scalar,& + write_attribute_r8_scalar, write_attribute_r4_1d,& + write_attribute_int_1d, write_attribute_r8_1d, write_attribute_char, & + write_attribute_short_scalar, write_attribute_short_1d, & + write_attribute_byte_scalar, write_attribute_byte_1d + end interface + + interface quantize_data + module procedure quantize_data_2d, quantize_data_3d, quantize_data_4d + end interface + + public :: open_dataset, create_dataset, close_dataset, Dataset, Variable, Dimension, & + read_vardata, read_attribute, write_vardata, write_attribute, get_ndim, & + get_nvar, get_var, get_dim, get_idate_from_time_units, & + get_time_units_from_idate, quantize_data, has_var, has_attr + + contains + + subroutine nccheck(status,halt,fname) + ! check return code, print error message + implicit none + integer, intent (in) :: status + logical, intent(in), optional :: halt + character(len=500), intent(in), optional :: fname + logical stopit + if (present(halt)) then + stopit = halt + else + stopit = .true. + endif + if (status /= nf90_noerr) then + write(0,*) status, trim(nf90_strerror(status)) + if (present(fname)) then + write(0,*) trim(fname) + end if + if (stopit) stop 99 + end if + end subroutine nccheck + + function get_dim(dset, dimname) result(dim) + type(Dataset) :: dset + type(Dimension) :: dim + character(len=*), intent(in) :: dimname + integer ndim + ndim = get_ndim(dset, dimname) + dim = dset%dimensions(ndim) + end function get_dim + + integer function get_ndim(dset, dimname) + ! get dimension index given name + type(Dataset), intent(in) :: dset + character(len=*), intent(in) :: dimname + integer ndim + get_ndim = -1 + do ndim=1,dset%ndims + if (trim(dset%dimensions(ndim)%name) == trim(dimname)) then + get_ndim = ndim + exit + endif + enddo + end function get_ndim + + function get_var(dset, varname) result (var) + type(Dataset) :: dset + type(Variable) :: var + character(len=*) :: varname + integer nvar + nvar = get_nvar(dset, varname) + var = dset%variables(nvar) + end function get_var + + logical function has_var(dset, varname) + ! returns .true. is varname exists in dset, otherwise .false. + type(Dataset) :: dset + character(len=*) :: varname + integer nvar + nvar = get_nvar(dset, varname) + if (nvar > 0) then + has_var=.true. + else + has_var=.false. + endif + end function has_var + + logical function has_attr(dset, attname, varname) + ! returns .true. if attribute exists in dset, otherwise .false. + ! use optional kwarg varname to check for a variable attribute. + type(Dataset) :: dset + character(len=*) :: attname + character(len=*), optional :: varname + integer nvar, varid, ncerr + nvar = get_nvar(dset, varname) + if(present(varname))then + nvar = get_nvar(dset,varname) + if (nvar < 0) then + has_attr = .false. + return + endif + varid = dset%variables(nvar)%varid + else + varid = NF90_GLOBAL + endif + ncerr = nf90_inquire_attribute(dset%ncid, varid, attname) + if (ncerr /= 0) then + has_attr=.false. + else + has_attr=.true. + endif + end function has_attr + + integer function get_nvar(dset,varname) + ! get variable index given name + type(Dataset), intent(in) :: dset + character(len=*), intent(in) :: varname + integer nvar + get_nvar = -1 + do nvar=1,dset%nvars + if (trim(dset%variables(nvar)%name) == trim(varname)) then + get_nvar = nvar + exit + endif + enddo + end function get_nvar + + subroutine set_varunlimdimlens_(dset,errcode) + ! reset dimension length (dimlens) for unlim dim for all variables + type(Dataset), intent(inout) :: dset + integer, intent(out), optional :: errcode + integer ndim,n,nvar,ncerr + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + ! loop over all vars + do nvar=1,dset%nvars + ! does var have unlim dimension? + if (dset%variables(nvar)%hasunlim) then + ! loop over all var dimensions + do ndim=1,dset%variables(nvar)%ndims + n = dset%variables(nvar)%dimindxs(ndim) + ! n is the dimension index for this variable dimension + ! if this dim is unlimited, update dimlens entry + if (dset%dimensions(n)%isunlimited) then + ncerr = nf90_inquire_dimension(dset%ncid,& + dset%dimensions(n)%dimid, & + len=dset%variables(nvar)%dimlens(ndim)) + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + return + else + call nccheck(ncerr) + endif + ! also update len attribute of Dimension object + dset%dimensions(n)%len = dset%variables(nvar)%dimlens(ndim) + endif + enddo + endif + enddo + end subroutine set_varunlimdimlens_ + + function open_dataset(filename,errcode,paropen, mpicomm) result(dset) + ! open existing dataset, create dataset object for reading netcdf file + ! if optional error return code errcode is not specified, + ! program will stop if a nonzero error code returned by the netcdf lib. + implicit none + character(len=*), intent(in) :: filename + type(Dataset) :: dset + integer, intent(out), optional :: errcode + logical, intent(in), optional :: paropen + integer, intent(in), optional :: mpicomm + integer ncerr,nunlimdim,ndim,nvar,n,formatnum + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if (present(paropen)) then + if (paropen) then + dset%isparallel = .true. + else + dset%isparallel = .false. + end if + else + dset%isparallel = .false. + end if + ! open netcdf file, get info, populate Dataset object. + if (dset%isparallel) then + if (present(mpicomm)) then + ncerr = nf90_open(trim(filename), ior(NF90_NOWRITE, NF90_MPIIO), & + comm=mpicomm, info = mpi_info_null, ncid=dset%ncid) + else + ncerr = nf90_open(trim(filename), ior(NF90_NOWRITE, NF90_MPIIO), & + comm=mpi_comm_world, info = mpi_info_null, ncid=dset%ncid) + end if + else + ncerr = nf90_open(trim(filename), NF90_NOWRITE, ncid=dset%ncid) + end if + if (return_errcode) then + call nccheck(ncerr,halt=.false.,fname=filename) + errcode=ncerr + if (ncerr /= 0) return + else + call nccheck(ncerr,fname=filename) + endif + ncerr = nf90_inquire(dset%ncid, dset%ndims, dset%nvars, dset%natts, nunlimdim, formatnum=formatnum) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.,fname=filename) + if (ncerr /= 0) return + else + call nccheck(ncerr,fname=filename) + endif + if (formatnum == nf90_format_netcdf4 .or. formatnum == nf90_format_netcdf4_classic) then + dset%ishdf5 = .true. + else + dset%ishdf5 = .false. + endif + dset%filename = trim(filename) + allocate(dset%variables(dset%nvars)) + allocate(dset%dimensions(dset%ndims)) + do ndim=1,dset%ndims + dset%dimensions(ndim)%dimid = ndim + ncerr = nf90_inquire_dimension(dset%ncid, ndim, name=dset%dimensions(ndim)%name, & + len=dset%dimensions(ndim)%len) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.,fname=filename) + if (ncerr /= 0) return + else + call nccheck(ncerr,fname=filename) + endif + if (ndim == nunlimdim) then + dset%dimensions(ndim)%isunlimited = .true. + else + dset%dimensions(ndim)%isunlimited = .false. + endif + enddo + do nvar=1,dset%nvars + dset%variables(nvar)%hasunlim = .false. + dset%variables(nvar)%varid = nvar + ncerr = nf90_inquire_variable(dset%ncid, nvar,& + name=dset%variables(nvar)%name,& + natts=dset%variables(nvar)%natts,& + xtype=dset%variables(nvar)%dtype,& + ndims=dset%variables(nvar)%ndims) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.,fname=filename) + if (ncerr /= 0) return + else + call nccheck(ncerr,fname=filename) + endif + allocate(dset%variables(nvar)%dimids(dset%variables(nvar)%ndims)) + allocate(dset%variables(nvar)%dimindxs(dset%variables(nvar)%ndims)) + allocate(dset%variables(nvar)%dimlens(dset%variables(nvar)%ndims)) + allocate(dset%variables(nvar)%chunksizes(dset%variables(nvar)%ndims)) + allocate(dset%variables(nvar)%dimnames(dset%variables(nvar)%ndims)) + if (dset%ishdf5) then + ncerr = nf90_inquire_variable(dset%ncid, nvar,& + dimids=dset%variables(nvar)%dimids,& + deflate_level=dset%variables(nvar)%deflate_level,& + chunksizes=dset%variables(nvar)%chunksizes,& + shuffle=dset%variables(nvar)%shuffle) + else + ncerr = nf90_inquire_variable(dset%ncid, nvar,& + dimids=dset%variables(nvar)%dimids) + endif + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.,fname=filename) + if (ncerr /= 0) return + else + call nccheck(ncerr,fname=filename) + endif + do ndim=1,dset%variables(nvar)%ndims + do n=1,dset%ndims + if (dset%variables(nvar)%dimids(ndim) == dset%dimensions(n)%dimid) then + exit + endif + enddo + dset%variables(nvar)%dimindxs(ndim) = n + dset%variables(nvar)%dimlens(ndim) = dset%dimensions(n)%len + dset%variables(nvar)%dimnames(ndim) = dset%dimensions(n)%name + if (dset%dimensions(n)%isunlimited) then + dset%variables(nvar)%hasunlim = .true. + endif + enddo + enddo + end function open_dataset + + function create_dataset(filename, dsetin, copy_vardata, paropen, nocompress, mpicomm, errcode) result(dset) + ! create new dataset, using an existing dataset object to define + ! variables, dimensions and attributes. + ! If copy_vardata=T, all variable data (not just coordinate + ! variable data) is copied. Default is F (only coord var data + ! copied). + ! if optional nocompress=.true., outputfile will not use compression even if input file does + ! if optional error return code errcode is not specified, + ! program will stop if a nonzero error code returned by the netcdf lib. + implicit none + character(len=*), intent(in) :: filename + character(len=nf90_max_name) :: attname, varname + logical, intent(in), optional :: copy_vardata + type(Dataset) :: dset + type(Dataset), intent(in) :: dsetin + logical, intent(in), optional :: paropen + integer, intent(in), optional :: mpicomm + logical, intent(in), optional :: nocompress + integer, intent(out), optional :: errcode + integer ncerr,ndim,nvar,n,ishuffle,natt + logical copyd, coordvar, compress + real(8), allocatable, dimension(:) :: values_1d + real(8), allocatable, dimension(:,:) :: values_2d + real(8), allocatable, dimension(:,:,:) :: values_3d + real(8), allocatable, dimension(:,:,:,:) :: values_4d + real(8), allocatable, dimension(:,:,:,:,:) :: values_5d + integer, allocatable, dimension(:) :: ivalues_1d + integer, allocatable, dimension(:,:) :: ivalues_2d + integer, allocatable, dimension(:,:,:) :: ivalues_3d + integer, allocatable, dimension(:,:,:,:) :: ivalues_4d + integer, allocatable, dimension(:,:,:,:,:) :: ivalues_5d + character, allocatable, dimension(:) :: cvalues_1d + character, allocatable, dimension(:,:) :: cvalues_2d + character, allocatable, dimension(:,:,:) :: cvalues_3d + character, allocatable, dimension(:,:,:,:) :: cvalues_4d + character, allocatable, dimension(:,:,:,:,:) :: cvalues_5d + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if (present(copy_vardata)) then + copyd = .true. ! copy all variable data + else + copyd = .false. ! only copy coordinate variable data + endif + if (present(paropen)) then + if (paropen) then + dset%isparallel = .true. + else + dset%isparallel = .false. + end if + else + dset%isparallel = .false. + end if + compress = .true. + if (present(nocompress)) then + if (nocompress) then + compress = .false. + end if + end if + ! create netcdf file + if (dsetin%ishdf5) then + if (dset%isparallel) then + if (present(mpicomm)) then + ncerr = nf90_create(trim(filename), & + cmode=IOR(NF90_CLOBBER,NF90_NETCDF4), ncid=dset%ncid, & + comm = mpicomm, info = mpi_info_null) + else + ncerr = nf90_create(trim(filename), & + cmode=IOR(NF90_CLOBBER,NF90_NETCDF4), ncid=dset%ncid, & + comm = mpi_comm_world, info = mpi_info_null) + end if + else + ncerr = nf90_create(trim(filename), & + cmode=IOR(IOR(NF90_CLOBBER,NF90_NETCDF4),NF90_CLASSIC_MODEL), & + !cmode=IOR(NF90_CLOBBER,NF90_NETCDF4), & + ncid=dset%ncid) + end if + dset%ishdf5 = .true. + else + ncerr = nf90_create(trim(filename), & + cmode=IOR(IOR(NF90_CLOBBER,NF90_64BIT_OFFSET),NF90_SHARE), & + ncid=dset%ncid) + dset%ishdf5 = .false. + endif + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.,fname=filename) + if (ncerr /= 0) return + else + call nccheck(ncerr,fname=filename) + endif + ! copy global attributes + do natt=1,dsetin%natts + ncerr = nf90_inq_attname(dsetin%ncid, NF90_GLOBAL, natt, attname) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + ncerr = nf90_copy_att(dsetin%ncid, NF90_GLOBAL, attname, dset%ncid, NF90_GLOBAL) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + enddo + dset%natts = dsetin%natts + dset%filename = trim(filename) + dset%ndims = dsetin%ndims + dset%nvars = dsetin%nvars + allocate(dset%variables(dsetin%nvars)) + allocate(dset%dimensions(dsetin%ndims)) + ! create dimensions + do ndim=1,dsetin%ndims + if (dsetin%dimensions(ndim)%isunlimited) then + ncerr = nf90_def_dim(dset%ncid, trim(dsetin%dimensions(ndim)%name), & + NF90_UNLIMITED, & + dset%dimensions(ndim)%dimid) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + dset%dimensions(ndim)%isunlimited = .true. + dset%nunlimdim = ndim + dset%dimensions(ndim)%len = 0 + dset%dimensions(ndim)%name = trim(dsetin%dimensions(ndim)%name) + else + ncerr = nf90_def_dim(dset%ncid, trim(dsetin%dimensions(ndim)%name),& + dsetin%dimensions(ndim)%len, & + dset%dimensions(ndim)%dimid) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + dset%dimensions(ndim)%len = dsetin%dimensions(ndim)%len + dset%dimensions(ndim)%isunlimited = .false. + dset%dimensions(ndim)%name = trim(dsetin%dimensions(ndim)%name) + endif + enddo + ! create variables + do nvar=1,dsetin%nvars + dset%variables(nvar)%hasunlim = .false. + dset%variables(nvar)%ndims = dsetin%variables(nvar)%ndims + allocate(dset%variables(nvar)%dimids(dset%variables(nvar)%ndims)) + allocate(dset%variables(nvar)%dimindxs(dset%variables(nvar)%ndims)) + allocate(dset%variables(nvar)%dimnames(dset%variables(nvar)%ndims)) + allocate(dset%variables(nvar)%dimlens(dset%variables(nvar)%ndims)) + allocate(dset%variables(nvar)%chunksizes(dset%variables(nvar)%ndims)) + dset%variables(nvar)%chunksizes = dsetin%variables(nvar)%chunksizes + do ndim=1,dset%variables(nvar)%ndims + do n=1,dset%ndims + if (trim(dsetin%variables(nvar)%dimnames(ndim)) == & + trim(dset%dimensions(n)%name)) then + exit + endif + enddo + dset%variables(nvar)%dimindxs(ndim) = n + dset%variables(nvar)%dimids(ndim) = dset%dimensions(n)%dimid + dset%variables(nvar)%dimlens(ndim) = dset%dimensions(n)%len + dset%variables(nvar)%dimnames(ndim) = dset%dimensions(n)%name + if (dset%dimensions(n)%isunlimited) then + dset%variables(nvar)%hasunlim = .true. + endif + enddo + dset%variables(nvar)%name = dsetin%variables(nvar)%name + dset%variables(nvar)%dtype = dsetin%variables(nvar)%dtype + if (maxval(dset%variables(nvar)%chunksizes) > 0 .and. dset%ishdf5) then + ! workaround for older versions of netcdf-fortran that don't + ! like zero chunksize to be specified. + ncerr = nf90_def_var(dset%ncid, & + trim(dset%variables(nvar)%name),& + dset%variables(nvar)%dtype, & + dset%variables(nvar)%dimids, & + dset%variables(nvar)%varid, & + chunksizes=dset%variables(nvar)%chunksizes) + else + ncerr = nf90_def_var(dset%ncid, & + trim(dset%variables(nvar)%name),& + dset%variables(nvar)%dtype, & + dset%variables(nvar)%dimids, & + dset%variables(nvar)%varid) + endif + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + if (dsetin%variables(nvar)%deflate_level > 0 .and. dset%ishdf5 .and. compress) then + if (dsetin%variables(nvar)%shuffle) then + ishuffle=1 + else + ishuffle=0 + endif + ncerr = nf90_def_var_deflate(dset%ncid, dset%variables(nvar)%varid,& + ishuffle,1,dsetin%variables(nvar)%deflate_level) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + dset%variables(nvar)%shuffle = dsetin%variables(nvar)%shuffle + dset%variables(nvar)%deflate_level = & + dsetin%variables(nvar)%deflate_level + endif + ! copy variable attributes + do natt=1,dsetin%variables(nvar)%natts + ncerr = nf90_inq_attname(dsetin%ncid, dsetin%variables(nvar)%varid, natt, attname) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + if (.not. compress) then + if (trim(attname) == 'max_abs_compression_error' & + .or. trim(attname) == 'nbits') then + cycle + end if + end if + ncerr = nf90_copy_att(dsetin%ncid, dsetin%variables(nvar)%varid, attname, dset%ncid, dset%variables(nvar)%varid) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + enddo + enddo + ncerr = nf90_enddef(dset%ncid) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + ! copy variable data + ! assumes data is real (32 or 64 bit), or integer (16 or 32 bit) and 1-4d. + do nvar=1,dsetin%nvars + varname = trim(dsetin%variables(nvar)%name) + ! is this variable a coordinate variable? + coordvar = .false. + if (trim(varname) == 'lats' .or. trim(varname) == 'lons' .or. & + trim(varname) == 'lat' .or. trim(varname) == 'lon') then + coordvar = .true. + else + do ndim=1,dset%ndims + if (trim(varname) == trim(dset%dimensions(ndim)%name)) then + coordvar = .true. + endif + enddo + endif + ! if copy_data flag not given, and not a coordinate var, + ! skip to next var. + if (.not. coordvar .and. .not. copyd) cycle + ! real variable + if (dsetin%variables(nvar)%dtype == NF90_FLOAT .or.& + dsetin%variables(nvar)%dtype == NF90_DOUBLE) then + if (dsetin%variables(nvar)%ndims == 1) then + call read_vardata(dsetin, varname, values_1d) + call write_vardata(dset, varname, values_1d) + else if (dsetin%variables(nvar)%ndims == 2) then + call read_vardata(dsetin, varname, values_2d) + call write_vardata(dset, varname, values_2d) + else if (dsetin%variables(nvar)%ndims == 3) then + call read_vardata(dsetin, varname, values_3d) + call write_vardata(dset, varname, values_3d) + else if (dsetin%variables(nvar)%ndims == 4) then + call read_vardata(dsetin, varname, values_4d) + call write_vardata(dset, varname, values_4d) + else if (dsetin%variables(nvar)%ndims == 5) then + call read_vardata(dsetin, varname, values_5d) + call write_vardata(dset, varname, values_5d) + endif + ! integer var + elseif (dsetin%variables(nvar)%dtype == NF90_INT .or.& + dsetin%variables(nvar)%dtype == NF90_BYTE .or.& + dsetin%variables(nvar)%dtype == NF90_SHORT) then + if (dsetin%variables(nvar)%ndims == 1) then + call read_vardata(dsetin, varname, ivalues_1d) + call write_vardata(dset, varname, ivalues_1d) + else if (dsetin%variables(nvar)%ndims == 2) then + call read_vardata(dsetin, varname, ivalues_2d) + call write_vardata(dset, varname, ivalues_2d) + else if (dsetin%variables(nvar)%ndims == 3) then + call read_vardata(dsetin, varname, ivalues_3d) + call write_vardata(dset, varname, ivalues_3d) + else if (dsetin%variables(nvar)%ndims == 4) then + call read_vardata(dsetin, varname, ivalues_4d) + call write_vardata(dset, varname, ivalues_4d) + else if (dsetin%variables(nvar)%ndims == 5) then + call read_vardata(dsetin, varname, ivalues_5d) + call write_vardata(dset, varname, ivalues_5d) + endif + elseif (dsetin%variables(nvar)%dtype == NF90_CHAR) then + if (dsetin%variables(nvar)%ndims == 1) then + call read_vardata(dsetin, varname, cvalues_1d) + call write_vardata(dset, varname, cvalues_1d) + else if (dsetin%variables(nvar)%ndims == 2) then + call read_vardata(dsetin, varname, cvalues_2d) + call write_vardata(dset, varname, cvalues_2d) + else if (dsetin%variables(nvar)%ndims == 3) then + call read_vardata(dsetin, varname, cvalues_3d) + call write_vardata(dset, varname, cvalues_3d) + else if (dsetin%variables(nvar)%ndims == 4) then + call read_vardata(dsetin, varname, cvalues_4d) + call write_vardata(dset, varname, cvalues_4d) + else if (dsetin%variables(nvar)%ndims == 5) then + call read_vardata(dsetin, varname, cvalues_5d) + call write_vardata(dset, varname, cvalues_5d) + endif + else + print *,'not copying variable ',trim(adjustl(varname)),& + ' (unsupported data type or rank)' + endif + enddo + end function create_dataset + + subroutine close_dataset(dset,errcode) + ! close netcdf file, deallocate members of dataset object. + ! if optional error return code errcode is not specified, + ! program will stop if a nonzero error code returned by the netcdf lib. + type(Dataset), intent(inout) :: dset + integer, intent(out), optional :: errcode + integer ncerr, nvar + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + ncerr = nf90_close(ncid=dset%ncid) + if (return_errcode) then + errcode=ncerr + call nccheck(ncerr,halt=.false.) + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + do nvar=1,dset%nvars + deallocate(dset%variables(nvar)%dimids) + deallocate(dset%variables(nvar)%dimindxs) + deallocate(dset%variables(nvar)%dimlens) + deallocate(dset%variables(nvar)%chunksizes) + deallocate(dset%variables(nvar)%dimnames) + enddo + deallocate(dset%variables,dset%dimensions) + end subroutine close_dataset + + !subroutine read_vardata(dset,varname,values,nslice,slicedim,errcode) + ! read data from variable varname in dataset dset, return in it array values. + ! dset: Input dataset instance returned by open_dataset/create_dataset. + ! varname: Input string name of variable. + ! values: Array to hold variable data. Must be + ! an allocatable array with same rank + ! as variable varname (or 1 dimension less). + ! nslice: optional index along dimension slicedim + ! slicedim: optional, if nslice is set, index of which dimension to slice with + ! nslice, default is ndims + ! ncstart: optional, if ncstart and nccount are set, manually specify the + ! start and count of netCDF read + ! nccount: optional, if ncstart and nccount are set, manually specify the + ! start and count of netCDF read + ! errcode: optional error return code. If not specified, + ! program will stop if a nonzero error code returned + ! from netcdf library. + + !subroutine write_vardata(dset,varname,values,nslice,slicedim,errcode) + ! write data (in array values) to variable varname in dataset dset. + ! dset: Input dataset instance returned by open_dataset/create_dataset. + ! varname: Input string name of variable. + ! values: Array with variable data. Must be + ! an allocatable array with same rank + ! as variable varname (or 1 dimension less). + ! nslice: optional index along dimension slicedim + ! slicedim: optional, if nslice is set, index of which dimension to slice with + ! nslice, default is ndims + ! ncstart: optional, if ncstart and nccount are set, manually specify the + ! start and count of netCDF write + ! nccount: optional, if ncstart and nccount are set, manually specify the + ! start and count of netCDF write + ! errcode: optional error return code. If not specified, + ! program will stop if a nonzero error code returned + ! from netcdf library. + + !subroutine read_attribute(dset, attname, values, varname, errcode) + ! read attribute 'attname' return in 'values'. If optional + ! argument 'varname' is given, a variable attribute is returned. + ! if the attribute is a 1d array, values should be an allocatable 1d + ! array of the correct type. + + !subroutine write_attribute(dset, attname, values, varname, errcode) + ! write attribute 'attname' with data in 'values'. If optional + ! argument 'varname' is given, a variable attribute is written. + ! values can be a real(4), real(8), integer, string or 1d array. + + subroutine read_vardata_1d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), allocatable, dimension(:), intent(inout) :: values + include "read_vardata_code_1d.f90" + end subroutine read_vardata_1d_r4 + + subroutine read_vardata_2d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), allocatable, dimension(:,:), intent(inout) :: values + include "read_vardata_code_2d.f90" + end subroutine read_vardata_2d_r4 + + subroutine read_vardata_3d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), allocatable, dimension(:,:,:), intent(inout) :: values + include "read_vardata_code_3d.f90" + end subroutine read_vardata_3d_r4 + + subroutine read_vardata_4d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), allocatable, dimension(:,:,:,:), intent(inout) :: values + include "read_vardata_code_4d.f90" + end subroutine read_vardata_4d_r4 + + subroutine read_vardata_5d_r4(dset, varname, values, errcode) + real(4), allocatable, dimension(:,:,:,:,:), intent(inout) :: values + include "read_vardata_code_5d.f90" + end subroutine read_vardata_5d_r4 + + subroutine read_vardata_1d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), allocatable, dimension(:), intent(inout) :: values + include "read_vardata_code_1d.f90" + end subroutine read_vardata_1d_r8 + + subroutine read_vardata_2d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), allocatable, dimension(:,:), intent(inout) :: values + include "read_vardata_code_2d.f90" + end subroutine read_vardata_2d_r8 + + subroutine read_vardata_3d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), allocatable, dimension(:,:,:), intent(inout) :: values + include "read_vardata_code_3d.f90" + end subroutine read_vardata_3d_r8 + + subroutine read_vardata_4d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), allocatable, dimension(:,:,:,:), intent(inout) :: values + include "read_vardata_code_4d.f90" + end subroutine read_vardata_4d_r8 + + subroutine read_vardata_5d_r8(dset, varname, values, errcode) + real(8), allocatable, dimension(:,:,:,:,:), intent(inout) :: values + include "read_vardata_code_5d.f90" + end subroutine read_vardata_5d_r8 + + subroutine read_vardata_1d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, allocatable, dimension(:), intent(inout) :: values + include "read_vardata_code_1d.f90" + end subroutine read_vardata_1d_int + + subroutine read_vardata_2d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, allocatable, dimension(:,:), intent(inout) :: values + include "read_vardata_code_2d.f90" + end subroutine read_vardata_2d_int + + subroutine read_vardata_3d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, allocatable, dimension(:,:,:), intent(inout) :: values + include "read_vardata_code_3d.f90" + end subroutine read_vardata_3d_int + + subroutine read_vardata_4d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, allocatable, dimension(:,:,:,:), intent(inout) :: values + include "read_vardata_code_4d.f90" + end subroutine read_vardata_4d_int + + subroutine read_vardata_5d_int(dset, varname, values, errcode) + integer, allocatable, dimension(:,:,:,:,:), intent(inout) :: values + include "read_vardata_code_5d.f90" + end subroutine read_vardata_5d_int + + subroutine read_vardata_1d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), allocatable, dimension(:), intent(inout) :: values + include "read_vardata_code_1d.f90" + end subroutine read_vardata_1d_short + + subroutine read_vardata_2d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), allocatable, dimension(:,:), intent(inout) :: values + include "read_vardata_code_2d.f90" + end subroutine read_vardata_2d_short + + subroutine read_vardata_3d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), allocatable, dimension(:,:,:), intent(inout) :: values + include "read_vardata_code_3d.f90" + end subroutine read_vardata_3d_short + + subroutine read_vardata_4d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), allocatable, dimension(:,:,:,:), intent(inout) :: values + include "read_vardata_code_4d.f90" + end subroutine read_vardata_4d_short + + subroutine read_vardata_5d_short(dset, varname, values, errcode) + integer(2), allocatable, dimension(:,:,:,:,:), intent(inout) :: values + include "read_vardata_code_5d.f90" + end subroutine read_vardata_5d_short + + subroutine read_vardata_1d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), allocatable, dimension(:), intent(inout) :: values + include "read_vardata_code_1d.f90" + end subroutine read_vardata_1d_byte + + subroutine read_vardata_2d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), allocatable, dimension(:,:), intent(inout) :: values + include "read_vardata_code_2d.f90" + end subroutine read_vardata_2d_byte + + subroutine read_vardata_3d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), allocatable, dimension(:,:,:), intent(inout) :: values + include "read_vardata_code_3d.f90" + end subroutine read_vardata_3d_byte + + subroutine read_vardata_4d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), allocatable, dimension(:,:,:,:), intent(inout) :: values + include "read_vardata_code_4d.f90" + end subroutine read_vardata_4d_byte + + subroutine read_vardata_5d_byte(dset, varname, values, errcode) + integer(1), allocatable, dimension(:,:,:,:,:), intent(inout) :: values + include "read_vardata_code_5d.f90" + end subroutine read_vardata_5d_byte + + subroutine read_vardata_1d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, allocatable, dimension(:), intent(inout) :: values + include "read_vardata_code_1d.f90" + end subroutine read_vardata_1d_char + + subroutine read_vardata_2d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, allocatable, dimension(:,:), intent(inout) :: values + include "read_vardata_code_2d.f90" + end subroutine read_vardata_2d_char + + subroutine read_vardata_3d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, allocatable, dimension(:,:,:), intent(inout) :: values + include "read_vardata_code_3d.f90" + end subroutine read_vardata_3d_char + + subroutine read_vardata_4d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, allocatable, dimension(:,:,:,:), intent(inout) :: values + include "read_vardata_code_4d.f90" + end subroutine read_vardata_4d_char + + subroutine read_vardata_5d_char(dset, varname, values, errcode) + character, allocatable, dimension(:,:,:,:,:), intent(inout) :: values + include "read_vardata_code_5d.f90" + end subroutine read_vardata_5d_char + + subroutine write_vardata_1d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), dimension(:), intent(in) :: values + integer, intent(in), optional :: ncstart(1) + integer, intent(in), optional :: nccount(1) + include "write_vardata_code.f90" + end subroutine write_vardata_1d_r4 + + subroutine write_vardata_2d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), dimension(:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(2) + integer, intent(in), optional :: nccount(2) + include "write_vardata_code.f90" + end subroutine write_vardata_2d_r4 + + subroutine write_vardata_3d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), dimension(:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(3) + integer, intent(in), optional :: nccount(3) + include "write_vardata_code.f90" + end subroutine write_vardata_3d_r4 + + subroutine write_vardata_4d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), dimension(:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(4) + integer, intent(in), optional :: nccount(4) + include "write_vardata_code.f90" + end subroutine write_vardata_4d_r4 + + subroutine write_vardata_5d_r4(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(4), dimension(:,:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(5) + integer, intent(in), optional :: nccount(5) + include "write_vardata_code.f90" + end subroutine write_vardata_5d_r4 + + subroutine write_vardata_1d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), dimension(:), intent(in) :: values + integer, intent(in), optional :: ncstart(1) + integer, intent(in), optional :: nccount(1) + include "write_vardata_code.f90" + end subroutine write_vardata_1d_r8 + + subroutine write_vardata_2d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), dimension(:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(2) + integer, intent(in), optional :: nccount(2) + include "write_vardata_code.f90" + end subroutine write_vardata_2d_r8 + + subroutine write_vardata_3d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), dimension(:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(3) + integer, intent(in), optional :: nccount(3) + include "write_vardata_code.f90" + end subroutine write_vardata_3d_r8 + + subroutine write_vardata_4d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), dimension(:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(4) + integer, intent(in), optional :: nccount(4) + include "write_vardata_code.f90" + end subroutine write_vardata_4d_r8 + + subroutine write_vardata_5d_r8(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + real(8), dimension(:,:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(5) + integer, intent(in), optional :: nccount(5) + include "write_vardata_code.f90" + end subroutine write_vardata_5d_r8 + + subroutine write_vardata_1d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, dimension(:), intent(in) :: values + integer, intent(in), optional :: ncstart(1) + integer, intent(in), optional :: nccount(1) + include "write_vardata_code.f90" + end subroutine write_vardata_1d_int + + subroutine write_vardata_2d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, dimension(:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(2) + integer, intent(in), optional :: nccount(2) + include "write_vardata_code.f90" + end subroutine write_vardata_2d_int + + subroutine write_vardata_3d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, dimension(:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(3) + integer, intent(in), optional :: nccount(3) + include "write_vardata_code.f90" + end subroutine write_vardata_3d_int + + subroutine write_vardata_4d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, dimension(:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(4) + integer, intent(in), optional :: nccount(4) + include "write_vardata_code.f90" + end subroutine write_vardata_4d_int + + subroutine write_vardata_5d_int(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer, dimension(:,:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(5) + integer, intent(in), optional :: nccount(5) + include "write_vardata_code.f90" + end subroutine write_vardata_5d_int + + subroutine write_vardata_1d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), dimension(:), intent(in) :: values + integer, intent(in), optional :: ncstart(1) + integer, intent(in), optional :: nccount(1) + include "write_vardata_code.f90" + end subroutine write_vardata_1d_short + + subroutine write_vardata_2d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), dimension(:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(2) + integer, intent(in), optional :: nccount(2) + include "write_vardata_code.f90" + end subroutine write_vardata_2d_short + + subroutine write_vardata_3d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), dimension(:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(3) + integer, intent(in), optional :: nccount(3) + include "write_vardata_code.f90" + end subroutine write_vardata_3d_short + + subroutine write_vardata_4d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), dimension(:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(4) + integer, intent(in), optional :: nccount(4) + include "write_vardata_code.f90" + end subroutine write_vardata_4d_short + + subroutine write_vardata_5d_short(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(2), dimension(:,:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(5) + integer, intent(in), optional :: nccount(5) + include "write_vardata_code.f90" + end subroutine write_vardata_5d_short + + subroutine write_vardata_1d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), dimension(:), intent(in) :: values + integer, intent(in), optional :: ncstart(1) + integer, intent(in), optional :: nccount(1) + include "write_vardata_code.f90" + end subroutine write_vardata_1d_byte + + subroutine write_vardata_2d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), dimension(:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(2) + integer, intent(in), optional :: nccount(2) + include "write_vardata_code.f90" + end subroutine write_vardata_2d_byte + + subroutine write_vardata_3d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), dimension(:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(3) + integer, intent(in), optional :: nccount(3) + include "write_vardata_code.f90" + end subroutine write_vardata_3d_byte + + subroutine write_vardata_4d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), dimension(:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(4) + integer, intent(in), optional :: nccount(4) + include "write_vardata_code.f90" + end subroutine write_vardata_4d_byte + + subroutine write_vardata_5d_byte(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + integer(1), dimension(:,:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(5) + integer, intent(in), optional :: nccount(5) + include "write_vardata_code.f90" + end subroutine write_vardata_5d_byte + + subroutine write_vardata_1d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, dimension(:), intent(in) :: values + integer, intent(in), optional :: ncstart(1) + integer, intent(in), optional :: nccount(1) + include "write_vardata_code.f90" + end subroutine write_vardata_1d_char + + subroutine write_vardata_2d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, dimension(:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(2) + integer, intent(in), optional :: nccount(2) + include "write_vardata_code.f90" + end subroutine write_vardata_2d_char + + subroutine write_vardata_3d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, dimension(:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(3) + integer, intent(in), optional :: nccount(3) + include "write_vardata_code.f90" + end subroutine write_vardata_3d_char + + subroutine write_vardata_4d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, dimension(:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(4) + integer, intent(in), optional :: nccount(4) + include "write_vardata_code.f90" + end subroutine write_vardata_4d_char + + subroutine write_vardata_5d_char(dset, varname, values, nslice, slicedim, ncstart, nccount, errcode) + character, dimension(:,:,:,:,:), intent(in) :: values + integer, intent(in), optional :: ncstart(5) + integer, intent(in), optional :: nccount(5) + include "write_vardata_code.f90" + end subroutine write_vardata_5d_char + + subroutine read_attribute_int_scalar(dset, attname, values, varname, errcode) + integer, intent(inout) :: values + include "read_scalar_attribute_code.f90" + end subroutine read_attribute_int_scalar + + subroutine read_attribute_short_scalar(dset, attname, values, varname, errcode) + integer(2), intent(inout) :: values + include "read_scalar_attribute_code.f90" + end subroutine read_attribute_short_scalar + + subroutine read_attribute_byte_scalar(dset, attname, values, varname, errcode) + integer(1), intent(inout) :: values + include "read_scalar_attribute_code.f90" + end subroutine read_attribute_byte_scalar + + subroutine read_attribute_r4_scalar(dset, attname, values, varname, errcode) + real(4), intent(inout) :: values + include "read_scalar_attribute_code.f90" + end subroutine read_attribute_r4_scalar + + subroutine read_attribute_r8_scalar(dset, attname, values, varname, errcode) + real(8), intent(inout) :: values + include "read_scalar_attribute_code.f90" + end subroutine read_attribute_r8_scalar + + subroutine read_attribute_r4_1d(dset, attname, values, varname, errcode) + real(4), intent(inout), allocatable, dimension(:) :: values + include "read_attribute_code.f90" + end subroutine read_attribute_r4_1d + + subroutine read_attribute_r8_1d(dset, attname, values, varname, errcode) + real(8), intent(inout), allocatable, dimension(:) :: values + include "read_attribute_code.f90" + end subroutine read_attribute_r8_1d + + subroutine read_attribute_int_1d(dset, attname, values, varname, errcode) + integer, intent(inout), allocatable, dimension(:) :: values + include "read_attribute_code.f90" + end subroutine read_attribute_int_1d + + subroutine read_attribute_short_1d(dset, attname, values, varname, errcode) + integer(2), intent(inout), allocatable, dimension(:) :: values + include "read_attribute_code.f90" + end subroutine read_attribute_short_1d + + subroutine read_attribute_byte_1d(dset, attname, values, varname, errcode) + integer(1), intent(inout), allocatable, dimension(:) :: values + include "read_attribute_code.f90" + end subroutine read_attribute_byte_1d + + subroutine read_attribute_char(dset, attname, values, varname, errcode) + character(len=*), intent(inout) :: values + include "read_scalar_attribute_code.f90" + end subroutine read_attribute_char + + subroutine write_attribute_int_scalar(dset, attname, values, varname, errcode) + integer, intent(in) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_int_scalar + + subroutine write_attribute_short_scalar(dset, attname, values, varname, errcode) + integer(2), intent(in) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_short_scalar + + subroutine write_attribute_byte_scalar(dset, attname, values, varname, errcode) + integer(1), intent(in) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_byte_scalar + + subroutine write_attribute_r4_scalar(dset, attname, values, varname, errcode) + real(4), intent(in) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_r4_scalar + + subroutine write_attribute_r8_scalar(dset, attname, values, varname, errcode) + real(8), intent(in) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_r8_scalar + + subroutine write_attribute_r4_1d(dset, attname, values, varname, errcode) + real(4), intent(in), allocatable, dimension(:) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_r4_1d + + subroutine write_attribute_r8_1d(dset, attname, values, varname, errcode) + real(8), intent(in), allocatable, dimension(:) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_r8_1d + + subroutine write_attribute_int_1d(dset, attname, values, varname, errcode) + integer, intent(in), allocatable, dimension(:) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_int_1d + + subroutine write_attribute_short_1d(dset, attname, values, varname, errcode) + integer(2), intent(in), allocatable, dimension(:) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_short_1d + + subroutine write_attribute_byte_1d(dset, attname, values, varname, errcode) + integer(1), intent(in), allocatable, dimension(:) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_byte_1d + + subroutine write_attribute_char(dset, attname, values, varname, errcode) + character(len=*), intent(in) :: values + include "write_attribute_code.f90" + end subroutine write_attribute_char + + function get_idate_from_time_units(dset) result(idate) + ! return integer array with year,month,day,hour,minute,second + ! parsed from time units attribute. + type(Dataset), intent(in) :: dset + integer idate(6) + character(len=nf90_max_name) :: time_units + integer ipos1,ipos2 + call read_attribute(dset, 'units', time_units, 'time') + ipos1 = scan(time_units,"since",back=.true.)+1 + ipos2 = scan(time_units,"-",back=.false.)-1 + read(time_units(ipos1:ipos2),*) idate(1) + ipos1 = ipos2+2; ipos2=ipos1+1 + read(time_units(ipos1:ipos2),*) idate(2) + ipos1 = ipos2+2; ipos2=ipos1+1 + read(time_units(ipos1:ipos2),*) idate(3) + ipos1 = scan(time_units,":")-2 + ipos2 = ipos1+1 + read(time_units(ipos1:ipos2),*) idate(4) + ipos1 = ipos2+2 + ipos2 = ipos1+1 + read(time_units(ipos1:ipos2),*) idate(5) + ipos1 = ipos2+2 + ipos2 = ipos1+1 + read(time_units(ipos1:ipos2),*) idate(6) + end function get_idate_from_time_units + + function get_time_units_from_idate(idate, time_measure) result(time_units) + ! create time units attribute of form 'hours since YYYY-MM-DD HH:MM:SS' + ! from integer array with year,month,day,hour,minute,second + ! optional argument 'time_measure' can be used to change 'hours' to + ! 'days', 'minutes', 'seconds' etc. + character(len=*), intent(in), optional :: time_measure + integer, intent(in) :: idate(6) + character(len=12) :: timechar + character(len=nf90_max_name) :: time_units + if (present(time_measure)) then + timechar = trim(time_measure) + else + timechar = 'hours' + endif + write(time_units,101) idate +101 format(' since ',i4.4,'-',i2.2,'-',i2.2,' ',& + i2.2,':',i2.2,':',i2.2) + time_units = trim(adjustl(timechar))//time_units + end function get_time_units_from_idate + + subroutine quantize_data_2d(dataIn, dataOut, nbits, compress_err) + real(4), intent(in) :: dataIn(:,:) + real(4), intent(out) :: dataOut(:,:) + include "quantize_data_code.f90" + end subroutine quantize_data_2d + + subroutine quantize_data_3d(dataIn, dataOut, nbits, compress_err) + real(4), intent(in) :: dataIn(:,:,:) + real(4), intent(out) :: dataOut(:,:,:) + include "quantize_data_code.f90" + end subroutine quantize_data_3d + + subroutine quantize_data_4d(dataIn, dataOut, nbits, compress_err) + real(4), intent(in) :: dataIn(:,:,:,:) + real(4), intent(out) :: dataOut(:,:,:,:) + include "quantize_data_code.f90" + end subroutine quantize_data_4d + +end module module_fv3gfs_ncio diff --git a/src/fv3gfs_ncio/quantize_data_code.f90 b/src/fv3gfs_ncio/quantize_data_code.f90 new file mode 100644 index 0000000000..ece0f77463 --- /dev/null +++ b/src/fv3gfs_ncio/quantize_data_code.f90 @@ -0,0 +1,17 @@ + integer, intent(in) :: nbits + real(4), intent(out) :: compress_err + real(4) dataMin, dataMax, scale_fact, offset + ! if nbits not between 1 and 31, don't do anything + if (nbits <= 0 .or. nbits > 31) then + dataOut = dataIn + compress_err = 0.0 + return + endif + dataMax = maxval(dataIn); dataMin = minval(dataIn) + ! convert data to 32 bit integers in range 0 to 2**nbits-1, then cast + ! cast back to 32 bit floats (data is then quantized in steps + ! proportional to 2**nbits so last 32-nbits in floating + ! point representation should be zero for efficient zlib compression). + scale_fact = (dataMax - dataMin) / (2**nbits-1); offset = dataMin + dataOut = scale_fact*(nint((dataIn - offset) / scale_fact)) + offset + compress_err = maxval(abs(dataIn-dataOut)) diff --git a/src/fv3gfs_ncio/read_attribute_code.f90 b/src/fv3gfs_ncio/read_attribute_code.f90 new file mode 100644 index 0000000000..6a0bcffcd5 --- /dev/null +++ b/src/fv3gfs_ncio/read_attribute_code.f90 @@ -0,0 +1,35 @@ + type(Dataset), intent(in) :: dset + character(len=*), intent(in), optional :: varname + character(len=*), intent(in) :: attname + integer, intent(out), optional :: errcode + integer ncerr, varid, nvar, nlen + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if(present(varname))then + nvar = get_nvar(dset,varname) + varid = dset%variables(nvar)%varid + else + varid = NF90_GLOBAL + endif + ncerr = nf90_inquire_attribute(dset%ncid, varid, attname, len=nlen) + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + if (allocated(values)) deallocate(values) + allocate(values(nlen)) + ncerr = nf90_get_att(dset%ncid, varid, trim(attname), values) + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + else + call nccheck(ncerr) + endif diff --git a/src/fv3gfs_ncio/read_scalar_attribute_code.f90 b/src/fv3gfs_ncio/read_scalar_attribute_code.f90 new file mode 100644 index 0000000000..2b8c6ce046 --- /dev/null +++ b/src/fv3gfs_ncio/read_scalar_attribute_code.f90 @@ -0,0 +1,31 @@ + ! read attribute 'attname' return in 'values'. If optional + ! argument 'varname' is given, an variable attribute is returned. + ! if the attribute is an 1d array, values should be an allocatable 1d + ! array of the correct type. if values is allocated, it be deallocated + ! and reallocated. + type(Dataset), intent(in) :: dset + character(len=*), intent(in), optional :: varname + integer, intent(out), optional :: errcode + character(len=*), intent(in) :: attname + integer ncerr, varid, nvar + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if(present(varname))then + nvar = get_nvar(dset,varname) + varid = dset%variables(nvar)%varid + else + varid = NF90_GLOBAL + endif + ncerr = nf90_get_att(dset%ncid, varid, trim(attname), values) + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + return + else + call nccheck(ncerr) + endif diff --git a/src/fv3gfs_ncio/read_vardata_code_1d.f90 b/src/fv3gfs_ncio/read_vardata_code_1d.f90 new file mode 100644 index 0000000000..1a92b7fc16 --- /dev/null +++ b/src/fv3gfs_ncio/read_vardata_code_1d.f90 @@ -0,0 +1,75 @@ + type(Dataset), intent(in) :: dset + character(len=*), intent(in) :: varname + integer, intent(in), optional :: nslice + integer, intent(in), optional :: slicedim + integer, intent(in), optional :: ncstart(1) + integer, intent(in), optional :: nccount(1) + integer, intent(out), optional :: errcode + integer ncerr, nvar, n, nd, dimlen, ncount + integer, allocatable, dimension(:) :: start, count + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if (present(nslice)) then + ncount = nslice + else + ncount = 1 + endif + nvar = get_nvar(dset,varname) + allocate(start(dset%variables(nvar)%ndims),count(dset%variables(nvar)%ndims)) + start(:) = 1 + count(:) = 1 + if (present(slicedim)) then + nd = slicedim + else + nd = dset%variables(nvar)%ndims + end if + do n=1,dset%variables(nvar)%ndims + if (n == nd) then + start(n) = ncount + count(n) = 1 + else + start(n) = 1 + count(n) = dset%variables(nvar)%dimlens(n) + dimlen = dset%variables(nvar)%dimlens(n) + end if + end do + if (dset%variables(nvar)%ndims /= 1 .and. dset%variables(nvar)%ndims /= 2) then + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=nf90_ebaddim + return + else + print *,'rank of data array != variable ndims (or ndims-1)' + stop 99 + endif + endif + if (allocated(values)) deallocate(values) + if (present(ncstart) .and. present(nccount)) then + allocate(values(nccount(1))) + start(1)=ncstart(1); count(1)=nccount(1) + if (dset%variables(nvar)%ndims == 2) then + start(2)=1; count(2)=1 + end if + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values,& + start=start, count=count) + else + if (dset%variables(nvar)%ndims == 2) then + allocate(values(dimlen)) + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values,& + start=start, count=count) + else + allocate(values(dset%variables(nvar)%dimlens(1))) + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values) + end if + end if + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + else + call nccheck(ncerr) + endif diff --git a/src/fv3gfs_ncio/read_vardata_code_2d.f90 b/src/fv3gfs_ncio/read_vardata_code_2d.f90 new file mode 100644 index 0000000000..c0e62a6abb --- /dev/null +++ b/src/fv3gfs_ncio/read_vardata_code_2d.f90 @@ -0,0 +1,81 @@ + type(Dataset), intent(in) :: dset + character(len=*), intent(in) :: varname + integer, intent(in), optional :: nslice + integer, intent(in), optional :: slicedim + integer, intent(in), optional :: ncstart(2) + integer, intent(in), optional :: nccount(2) + integer, intent(out), optional :: errcode + integer ncerr, nvar, n, nd, ndim, ncount + integer, allocatable, dimension(:) :: start, count + integer :: dimlens(2) + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if (present(nslice)) then + ncount = nslice + else + ncount = 1 + endif + nvar = get_nvar(dset,varname) + allocate(start(dset%variables(nvar)%ndims),count(dset%variables(nvar)%ndims)) + start(:) = 1 + count(:) = 1 + dimlens(:) = 1 + if (present(slicedim)) then + nd = slicedim + else + nd = dset%variables(nvar)%ndims + end if + ndim = 1 + do n=1,dset%variables(nvar)%ndims + if (n == nd) then + start(n) = ncount + count(n) = 1 + else + start(n) = 1 + count(n) = dset%variables(nvar)%dimlens(n) + dimlens(ndim) = dset%variables(nvar)%dimlens(n) + ndim = ndim + 1 + end if + end do + + if (dset%variables(nvar)%ndims /= 2 .and. dset%variables(nvar)%ndims /= 3) then + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=nf90_ebaddim + return + else + print *,'rank of data array != variable ndims (or ndims-1)' + stop 99 + endif + endif + if (allocated(values)) deallocate(values) + if (present(ncstart) .and. present(nccount)) then + allocate(values(nccount(1),nccount(2))) + start(1)=ncstart(1); count(1)=nccount(1) + start(2)=ncstart(2); count(2)=nccount(2) + if (dset%variables(nvar)%ndims == 3) then + start(3)=1; count(3)=1 + end if + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values,& + start=start, count=count) + else + if (dset%variables(nvar)%ndims == 3) then + allocate(values(dimlens(1),dimlens(2))) + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values,& + start=start, count=count) + else + allocate(values(dset%variables(nvar)%dimlens(1),dset%variables(nvar)%dimlens(2))) + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values) + end if + end if + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + else + call nccheck(ncerr) + endif diff --git a/src/fv3gfs_ncio/read_vardata_code_3d.f90 b/src/fv3gfs_ncio/read_vardata_code_3d.f90 new file mode 100644 index 0000000000..cc426b2361 --- /dev/null +++ b/src/fv3gfs_ncio/read_vardata_code_3d.f90 @@ -0,0 +1,85 @@ + type(Dataset), intent(in) :: dset + character(len=*), intent(in) :: varname + integer, intent(in), optional :: nslice + integer, intent(in), optional :: slicedim + integer, intent(in), optional :: ncstart(3) + integer, intent(in), optional :: nccount(3) + integer, intent(out), optional :: errcode + integer ncerr, nvar, n, nd, ndim, ncount + integer, allocatable, dimension(:) :: start, count + integer :: dimlens(3) + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if (present(nslice)) then + ncount = nslice + else + ncount = 1 + endif + nvar = get_nvar(dset,varname) + allocate(start(dset%variables(nvar)%ndims),count(dset%variables(nvar)%ndims)) + start(:) = 1 + count(:) = 1 + dimlens(:) = 1 + if (present(slicedim)) then + nd = slicedim + else + nd = dset%variables(nvar)%ndims + end if + ndim = 1 + do n=1,dset%variables(nvar)%ndims + if (n == nd) then + start(n) = ncount + count(n) = 1 + else + start(n) = 1 + count(n) = dset%variables(nvar)%dimlens(n) + dimlens(ndim) = dset%variables(nvar)%dimlens(n) + ndim = ndim + 1 + end if + end do + + if (dset%variables(nvar)%ndims /= 3 .and. dset%variables(nvar)%ndims /= 4) then + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=nf90_ebaddim + return + else + print *,'rank of data array != variable ndims (or ndims-1)' + stop 99 + endif + endif + + if (allocated(values)) deallocate(values) + if (present(ncstart) .and. present(nccount)) then + allocate(values(nccount(1),nccount(2),nccount(3))) + start(1)=ncstart(1); count(1)=nccount(1) + start(2)=ncstart(2); count(2)=nccount(2) + start(3)=ncstart(3); count(3)=nccount(3) + if (dset%variables(nvar)%ndims == 4) then + start(4)=1; count(4)=1 + end if + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values,& + start=start, count=count) + else + if (dset%variables(nvar)%ndims == 4) then + allocate(values(dimlens(1),dimlens(2),dimlens(3))) + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values,& + start=start, count=count) + else + allocate(values(dset%variables(nvar)%dimlens(1),& + dset%variables(nvar)%dimlens(2),& + dset%variables(nvar)%dimlens(3))) + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values) + end if + end if + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + else + call nccheck(ncerr) + endif diff --git a/src/fv3gfs_ncio/read_vardata_code_4d.f90 b/src/fv3gfs_ncio/read_vardata_code_4d.f90 new file mode 100644 index 0000000000..fd3dd42153 --- /dev/null +++ b/src/fv3gfs_ncio/read_vardata_code_4d.f90 @@ -0,0 +1,83 @@ + type(Dataset), intent(in) :: dset + character(len=*), intent(in) :: varname + integer, intent(in), optional :: nslice + integer, intent(in), optional :: slicedim + integer, intent(in), optional :: ncstart(4) + integer, intent(in), optional :: nccount(4) + integer, intent(out), optional :: errcode + integer ncerr, nvar, n, nd, ndim, ncount + integer, allocatable, dimension(:) :: start, count + integer :: dimlens(4) + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if (present(nslice)) then + ncount = nslice + else + ncount = 1 + endif + nvar = get_nvar(dset,varname) + allocate(start(dset%variables(nvar)%ndims),count(dset%variables(nvar)%ndims)) + start(:) = 1 + count(:) = 1 + dimlens(:) = 1 + if (present(slicedim)) then + nd = slicedim + else + nd = dset%variables(nvar)%ndims + end if + ndim = 1 + do n=1,dset%variables(nvar)%ndims + if (n == nd) then + start(n) = ncount + count(n) = 1 + else + start(n) = 1 + count(n) = dset%variables(nvar)%dimlens(n) + dimlens(ndim) = dset%variables(nvar)%dimlens(n) + ndim = ndim + 1 + end if + end do + + if (dset%variables(nvar)%ndims /= 4 .and. dset%variables(nvar)%ndims /= 5) then + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=nf90_ebaddim + return + else + print *,'rank of data array != variable ndims (or ndims-1)' + stop 99 + endif + endif + + if (allocated(values)) deallocate(values) + if (present(ncstart) .and. present(nccount)) then + allocate(values(nccount(1),nccount(2),nccount(3),nccount(4))) + start(1)=ncstart(1); count(1)=nccount(1) + start(2)=ncstart(2); count(2)=nccount(2) + start(3)=ncstart(3); count(3)=nccount(3) + start(4)=ncstart(4); count(4)=nccount(4) + if (dset%variables(nvar)%ndims == 5) then + start(5)=1; count(5)=1 + end if + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values,& + start=start, count=count) + else + allocate(values(dimlens(1),dimlens(2),dimlens(3),dimlens(4))) + if (dset%variables(nvar)%ndims == 5) then + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values,& + start=start, count=count) + else + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values) + end if + end if + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + else + call nccheck(ncerr) + endif diff --git a/src/fv3gfs_ncio/read_vardata_code_5d.f90 b/src/fv3gfs_ncio/read_vardata_code_5d.f90 new file mode 100644 index 0000000000..ea9bd2e2cf --- /dev/null +++ b/src/fv3gfs_ncio/read_vardata_code_5d.f90 @@ -0,0 +1,35 @@ + type(Dataset), intent(in) :: dset + character(len=*), intent(in) :: varname + integer, intent(out), optional :: errcode + integer ncerr, nvar, n1,n2,n3,n4,n5 + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + nvar = get_nvar(dset,varname) + if (dset%variables(nvar)%ndims /= 5) then + if (return_errcode) then + errcode=nf90_ebaddim + return + else + print *,'rank of data array != variable ndims (or ndims-1)' + stop 99 + endif + endif + n1 = dset%variables(nvar)%dimlens(1) + n2 = dset%variables(nvar)%dimlens(2) + n3 = dset%variables(nvar)%dimlens(3) + n4 = dset%variables(nvar)%dimlens(4) + n5 = dset%variables(nvar)%dimlens(5) + if (allocated(values)) deallocate(values) + allocate(values(n1,n2,n3,n4,n5)) + ncerr = nf90_get_var(dset%ncid, dset%variables(nvar)%varid, values) + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + else + call nccheck(ncerr) + endif diff --git a/src/fv3gfs_ncio/write_attribute_code.f90 b/src/fv3gfs_ncio/write_attribute_code.f90 new file mode 100644 index 0000000000..c700a90dc2 --- /dev/null +++ b/src/fv3gfs_ncio/write_attribute_code.f90 @@ -0,0 +1,37 @@ + type(Dataset), intent(in) :: dset + character(len=*), intent(in), optional :: varname + character(len=*), intent(in) :: attname + integer, intent(out), optional :: errcode + integer ncerr, varid, nvar + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if(present(varname))then + nvar = get_nvar(dset,varname) + varid = dset%variables(nvar)%varid + else + varid = NF90_GLOBAL + endif + ncerr = nf90_redef(dset%ncid) + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + ncerr = nf90_put_att(dset%ncid, varid, trim(attname), values) + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + ncerr = nf90_enddef(dset%ncid) + return + else + call nccheck(ncerr) + ncerr = nf90_enddef(dset%ncid) + call nccheck(ncerr) + endif diff --git a/src/fv3gfs_ncio/write_vardata_code.f90 b/src/fv3gfs_ncio/write_vardata_code.f90 new file mode 100644 index 0000000000..a6f8d4ffb8 --- /dev/null +++ b/src/fv3gfs_ncio/write_vardata_code.f90 @@ -0,0 +1,97 @@ + type(Dataset), intent(inout) :: dset + character(len=*), intent(in) :: varname + integer, intent(in), optional :: nslice + integer, intent(in), optional :: slicedim + integer, intent(out), optional :: errcode + integer ncerr, nvar, ncount, ndim, nd, n + integer, allocatable, dimension(:) :: start, count, dimlens + logical is_slice + logical return_errcode + if(present(errcode)) then + return_errcode=.true. + errcode = 0 + else + return_errcode=.false. + endif + if (present(nslice)) then + ncount = nslice + is_slice = .true. + else + ncount = 1 + is_slice = .false. + endif + nvar = get_nvar(dset,varname) + allocate(start(dset%variables(nvar)%ndims),count(dset%variables(nvar)%ndims)) + allocate(dimlens(dset%variables(nvar)%ndims)) + start(:) = 1 + count(:) = 1 + dimlens(:) = 1 + if (present(slicedim)) then + nd = slicedim + else + nd = dset%variables(nvar)%ndims + end if + ndim = 1 + do n=1,dset%variables(nvar)%ndims + if (n == nd) then + start(n) = ncount + count(n) = 1 + else + start(n) = 1 + count(n) = dset%variables(nvar)%dimlens(n) + dimlens(ndim) = dset%variables(nvar)%dimlens(n) + ndim = ndim + 1 + end if + end do + + + + ncerr = nf90_var_par_access(dset%ncid, dset%variables(nvar)%varid, nf90_collective) + if (is_slice) then + if (dset%variables(nvar)%ndims == 4) then + ncerr = nf90_put_var(dset%ncid, dset%variables(nvar)%varid,values, & + start=start,count=count) + else if (dset%variables(nvar)%ndims == 3) then + ncerr = nf90_put_var(dset%ncid, dset%variables(nvar)%varid,values, & + start=start,count=count) + else if (dset%variables(nvar)%ndims == 2) then + ncerr = nf90_put_var(dset%ncid, dset%variables(nvar)%varid,values, & + start=start,count=count) + else if (dset%variables(nvar)%ndims == 1) then + if (return_errcode) then + errcode = -1 + return + else + print *,'cannot write a slice to a 1d variable' + stop 99 + endif + else if (dset%variables(nvar)%ndims > 4) then + if (return_errcode) then + errcode = -1 + return + else + print *,'only variables up to 4d supported' + stop 99 + endif + endif + else if (present(ncstart) .and. present(nccount)) then + ncerr = nf90_put_var(dset%ncid, dset%variables(nvar)%varid,values, & + start=ncstart, count=nccount) + else + ncerr = nf90_put_var(dset%ncid, dset%variables(nvar)%varid, values) + endif + if (return_errcode) then + call nccheck(ncerr,halt=.false.) + errcode=ncerr + if (ncerr /= 0) return + else + call nccheck(ncerr) + endif + ! reset unlim dim size for all variables + if (dset%variables(nvar)%hasunlim) then + if (return_errcode) then + call set_varunlimdimlens_(dset,errcode) + else + call set_varunlimdimlens_(dset) + endif + endif diff --git a/src/gsi/CMakeLists.txt b/src/gsi/CMakeLists.txt index 92ac4bea7f..7adab2eed1 100644 --- a/src/gsi/CMakeLists.txt +++ b/src/gsi/CMakeLists.txt @@ -84,7 +84,7 @@ cmake_minimum_required(VERSION 2.8) # Add the include paths message("MPI include PATH ${MPI_Fortran_INCLUDE_PATH}") - include_directories( ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} "./" ) + include_directories( ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ${FV3GFS_NCIO_INCS} "./" ) #define the name used for GSI Shared lib and add it with properties and include dirs set(GSISHAREDLIB "gsilib_shrd${debug_suffix}" CACHE INTERNAL "") @@ -147,7 +147,7 @@ cmake_minimum_required(VERSION 2.8) 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} ) + ${GSI_LDFLAGS} ${NCDIAG_LIBRARIES} ${GSDCLOUD_LIBRARY} ${ZLIB_LIBRARIES} ${wrflib} ${EXTRA_LINKER_FLAGS} ${FV3GFS_NCIO_LIBRARIES}) install(TARGETS ${GSIEXEC} RUNTIME DESTINATION ${CMAKE_INSTALL_PREFIX}/bin LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib diff --git a/src/gsi/anisofilter_glb.f90 b/src/gsi/anisofilter_glb.f90 index 7df94968bc..43e67a3baa 100644 --- a/src/gsi/anisofilter_glb.f90 +++ b/src/gsi/anisofilter_glb.f90 @@ -125,8 +125,8 @@ module anisofilter_glb use gsi_metguess_mod, only: gsi_metguess_bundle use gsi_bundlemod, only: gsi_bundlegetpointer - use anisofilter, only: lreadnorm, & - r015, & + use anberror, only: lreadnorm + use anisofilter, only: r015, & qlth_temp0, qltv_temp0, qlth_wind0, qltv_wind0, & scalex1, scalex2, scalex3, & stpcode_alloc, stpcode_namelist, & diff --git a/src/gsi/berror.f90 b/src/gsi/berror.f90 index 28aea0ce1c..ba501c6262 100644 --- a/src/gsi/berror.f90 +++ b/src/gsi/berror.f90 @@ -439,33 +439,37 @@ subroutine set_predictors_var end if if (new_tail) then - varprd(ii)=one_tenth - if (aircraft_t_bc .and. j==2) varprd(ii)=1.0e-3_r_kind - if (aircraft_t_bc .and. j==3) varprd(ii)=1.0e-4_r_kind + varprd(ii)=one_tenth*one_tenth + if (aircraft_t_bc .and. j==2) varprd(ii)=1.0e-4_r_kind + if (aircraft_t_bc .and. j==3) varprd(ii)=1.0e-5_r_kind else - if (obs_count<=3.0_r_kind) then + if (obs_count<=10.0_r_kind) then if (aircraft_t_bc .and. j==2) then - varA_t(j,i)=1.05_r_kind*varA_t(j,i)+1.0e-5_r_kind + varA_t(j,i)=1.01_r_kind*varA_t(j,i)+1.0e-6_r_kind else if (aircraft_t_bc .and. j==3) then - varA_t(j,i)=1.05_r_kind*varA_t(j,i)+1.0e-6_r_kind + varA_t(j,i)=1.01_r_kind*varA_t(j,i)+1.0e-7_r_kind else - varA_t(j,i)=1.05_r_kind*varA_t(j,i)+1.0e-4_r_kind + varA_t(j,i)=1.01_r_kind*varA_t(j,i)+1.0e-5_r_kind end if varprd(ii)=varA_t(j,i) else if (aircraft_t_bc .and. j==2) then - varprd(ii)=1.005_r_kind*varA_t(j,i)+1.0e-5_r_kind - else if (aircraft_t_bc .and. j==3) then varprd(ii)=1.005_r_kind*varA_t(j,i)+1.0e-6_r_kind + else if (aircraft_t_bc .and. j==3) then + varprd(ii)=1.005_r_kind*varA_t(j,i)+1.0e-7_r_kind else - varprd(ii)=1.005_r_kind*varA_t(j,i)+1.0e-4_r_kind + varprd(ii)=1.005_r_kind*varA_t(j,i)+1.0e-5_r_kind end if end if - if (varprd(ii)>one) varprd(ii)=one - if (varA_t(j,i)>one) varA_t(j,i)=one - if (aircraft_t_bc .and. j>1) then - if (varprd(ii)>one_tenth) varprd(ii)=one_tenth - if (varA_t(j,i)>one_tenth) varA_t(j,i)=one_tenth + if (varprd(ii)>one_tenth) varprd(ii)=one_tenth + if (varA_t(j,i)>one_tenth) varA_t(j,i)=one_tenth + if (aircraft_t_bc .and. j==2) then + if (varprd(ii)>1.0e-3_r_kind) varprd(ii)=1.0e-3_r_kind + if (varA_t(j,i)>1.0e-3_r_kind) varA_t(j,i)=1.0e-3_r_kind + end if + if (aircraft_t_bc .and. j==3) then + if (varprd(ii)>1.0e-4_r_kind) varprd(ii)=1.0e-4_r_kind + if (varA_t(j,i)>1.0e-4_r_kind) varA_t(j,i)=1.0e-4_r_kind end if end if end do @@ -527,7 +531,7 @@ subroutine reset_predictors_var if (aircraft_t_bc_pof) obs_count = ostats_t(j,i) if (aircraft_t_bc) obs_count = ostats_t(1,i) - if (obs_count<=3.0_r_kind .and. varprd(ii)>stndev) then + if (obs_count<=10.0_r_kind .and. varprd(ii)>stndev) then varprd(ii)=stndev if (aircraft_t_bc .and. j==2) varprd(ii)=one_tenth*stndev if (aircraft_t_bc .and. j==3) varprd(ii)=one_tenth*one_tenth*stndev diff --git a/src/gsi/constants.f90 b/src/gsi/constants.f90 index 9d7e7b0679..caf4331532 100644 --- a/src/gsi/constants.f90 +++ b/src/gsi/constants.f90 @@ -30,6 +30,7 @@ module constants ! 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 +! 2019-09-25 X.Su - put stndrd_atmos_ps constant values ! ! Subroutines Included: ! sub init_constants_derived - compute derived constants @@ -63,12 +64,12 @@ module constants 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 :: rrow,cmr,cws,r18,r60,r61,r63,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 :: r10,r100,sqrt_tiny_r_kind,r2000,r4000,r10000 + public :: r0_01,r0_02,r0_03,r0_04,r0_05,r1_25,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 @@ -81,6 +82,7 @@ module constants public :: izero, qimin, qsmin, qgmin,qrmin public :: partialSnowThreshold public :: soilmoistmin + public :: stndrd_atmos_ps ! Declare derived constants integer(i_kind):: huge_i_kind @@ -106,7 +108,7 @@ module constants 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) + real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) ! Numeric constants @@ -123,13 +125,17 @@ module constants 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:: r1_25 = 1.25_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:: r18 = 18.0_r_kind real(r_kind),parameter:: r60 = 60._r_kind + real(r_kind),parameter:: r61 = 61._r_kind + real(r_kind),parameter:: r63 = 63._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 @@ -137,7 +143,7 @@ module constants 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:: r10000 = 10000.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 diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90 index 01bb3bce40..a1c0a61ed9 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -33,6 +33,8 @@ module control_vectors ! 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. +! 2019-09-13 martin - added incvars_to_zero variable for writing out fv3 netCDF increments +! 2019-10-28 martin - added incvars_zero_strat variable for zeroing out increments above tropopause ! ! subroutines included: ! sub init_anacv @@ -131,6 +133,10 @@ module control_vectors public nrf2_loc,nrf3_loc,nmotl_loc ! what are these for?? public ntracer +public :: incvars_to_zero ! array of fieldnames to zero out increments for +public :: incvars_zero_strat ! array of fieldnames to zero out increments above tropopause +public :: incvars_efold ! scale factor x in which e^(-(k-ktrop)/x) for above fields + type control_vector integer(i_kind) :: lencv real(r_kind), pointer :: values(:) => NULL() @@ -172,6 +178,9 @@ module control_vectors real(r_kind) ,allocatable,dimension(:) :: an_amp0 logical :: llinit = .false. +character(len=12),allocatable,dimension(:) :: incvars_to_zero +character(len=12),allocatable,dimension(:) :: incvars_zero_strat +real(r_kind) :: incvars_efold ! ---------------------------------------------------------------------- INTERFACE ASSIGNMENT (=) @@ -336,6 +345,11 @@ subroutine init_anacv allocate(cvarsmd(mvars)) allocate(atsfc_sdv(mvars)) allocate(an_amp0(nvars)) +allocate(incvars_to_zero(nvars)) +allocate(incvars_zero_strat(nvars)) +incvars_to_zero(:) = 'NONE' +incvars_zero_strat(:) = 'NONE' +incvars_efold = 5.0_r_kind ! want to rid code from the following ... nrf=nc2d+nc3d diff --git a/src/gsi/convinfo.f90 b/src/gsi/convinfo.f90 index eda9f9e305..9b19a29b06 100755 --- a/src/gsi/convinfo.f90 +++ b/src/gsi/convinfo.f90 @@ -19,6 +19,7 @@ module convinfo ! parameter for the option to keep thinned data as ! monitored ! 2016-03-02 s.liu/carley - remove use_reflectivity and use i_gsdcldanal_type +! 2019-05-23 su - add ibeta and ikapa for new VQC parameters ! ! Subroutines Included: @@ -46,6 +47,9 @@ module convinfo ! def pmesh_conv - size of vertical thinning mesh ! def pmot_conv - option to keep thinned data out ! def ptime_conv - option to add time dimension +! def ibeta -new VQC parameter +! def ikapa -new VQC parameter + ! ! ! count,max # of coefs @@ -79,6 +83,8 @@ module convinfo public :: id_drifter public :: id_ship public :: ec_amv_qc + public :: ibeta,ikapa ! for new variational QC + logical diag_conv logical :: ihave_pm2_5 @@ -90,7 +96,7 @@ module convinfo real(r_kind),allocatable,dimension(:)::ctwind,cgross,cermax,cermin,cvar_b,cvar_pg, & rmesh_conv,pmesh_conv,pmot_conv,ptime_conv integer(i_kind),allocatable,dimension(:):: ncmiter,ncgroup,ncnumgrp,icuse,ictype,icsubtype,& - ithin_conv,index_sub + ithin_conv,index_sub,ibeta,ikapa character(len=16),allocatable,dimension(:)::ioctype logical,save :: convinfo_initialized=.false. @@ -166,7 +172,7 @@ subroutine convinfo_read character(len=1)cflg character(len=7) iotype - character(len=120) crecord + character(len=140) crecord integer(i_kind) lunin,i,nc,ier,istat integer(i_kind) nlines integer(i_kind) ictypet,icsubtypet,icuset @@ -184,7 +190,7 @@ subroutine convinfo_read cflg=' ' iotype=' ' read(lunin,1030,iostat=istat,end=1130)cflg,iotype,crecord -1030 format(a1,a7,2x,a120) +1030 format(a1,a7,2x,a140) if (istat /= 0) exit nlines=nlines+1 if(cflg == '!')cycle @@ -214,7 +220,7 @@ subroutine convinfo_read ncnumgrp(nconvtype),icuse(nconvtype),ictype(nconvtype),icsubtype(nconvtype), & ioctype(nconvtype), index_sub(nconvtype),& ithin_conv(nconvtype),rmesh_conv(nconvtype),pmesh_conv(nconvtype),& - pmot_conv(nconvtype),ptime_conv(nconvtype), & + pmot_conv(nconvtype),ptime_conv(nconvtype),ibeta(nconvtype),ikapa(nconvtype), & stat=ier ) if ( ier /= 0 ) then write(6,*) 'CONVINFO_READ: allocate 1 failed' @@ -227,6 +233,8 @@ subroutine convinfo_read index_sub(i)=2 pmot_conv(i)=zero ptime_conv(i)=zero + ibeta(i)=0 + ikapa(i)=0 enddo nc=0 @@ -256,9 +264,14 @@ subroutine convinfo_read ! ctwind(nc), ! ncnumgrp(nc), - read(crecord,*)ictype(nc),icsubtype(nc),icuse(nc),ctwind(nc),ncnumgrp(nc), & + read(crecord,*,iostat=istat)ictype(nc),icsubtype(nc),icuse(nc),ctwind(nc),ncnumgrp(nc), & + ncgroup(nc),ncmiter(nc),cgross(nc),cermax(nc),cermin(nc),cvar_b(nc),cvar_pg(nc), & + ithin_conv(nc),rmesh_conv(nc),pmesh_conv(nc),idum,pmot_conv(nc),ptime_conv(nc),ibeta(nc),ikapa(nc) + if(istat /=0) then + read(crecord,*,iostat=istat)ictype(nc),icsubtype(nc),icuse(nc),ctwind(nc),ncnumgrp(nc), & ncgroup(nc),ncmiter(nc),cgross(nc),cermax(nc),cermin(nc),cvar_b(nc),cvar_pg(nc), & ithin_conv(nc),rmesh_conv(nc),pmesh_conv(nc),idum,pmot_conv(nc),ptime_conv(nc) + endif if(nc >=2 )then if(trim(ioctype(nc))==trim(ioctype(nc-1)) .and. ictype(nc)==ictype(nc-1)) then index_sub(nc)=index_sub(nc-1)+1 @@ -266,8 +279,8 @@ subroutine convinfo_read endif if(print_verbose .and. mype == 0)write(6,1031)ioctype(nc),ictype(nc),icsubtype(nc),icuse(nc),ctwind(nc),ncnumgrp(nc), & ncgroup(nc),ncmiter(nc),cgross(nc),cermax(nc),cermin(nc),cvar_b(nc),cvar_pg(nc), & - ithin_conv(nc),rmesh_conv(nc),pmesh_conv(nc),idum,pmot_conv(nc),ptime_conv(nc),index_sub(nc) -1031 format('READ_CONVINFO: ',a7,1x,i3,1x,i4,1x,i2,1x,g13.6,1x,3(I3,1x),5g13.6,i5,2g13.6,i5,2g13.6,i5) + ithin_conv(nc),rmesh_conv(nc),pmesh_conv(nc),idum,pmot_conv(nc),ptime_conv(nc),index_sub(nc),ibeta(nc),ikapa(nc) +1031 format('READ_CONVINFO: ',a7,1x,i3,1x,i4,1x,i2,1x,g13.6,1x,3(I3,1x),5g13.6,i5,2g13.6,i5,2g13.6,3i5) enddo close(lunin) @@ -309,7 +322,7 @@ subroutine convinfo_destroy ncnumgrp,icuse,ictype,icsubtype, & ioctype,index_sub, & ithin_conv,rmesh_conv,pmesh_conv, & - pmot_conv,ptime_conv, & + pmot_conv,ptime_conv,ibeta,ikapa, & stat=ier ) if ( ier /= 0 ) then write(6,*) 'CONVINFO_DESTROY: deallocate failed' diff --git a/src/gsi/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90 index 7ac201305a..c56c1e1764 100644 --- a/src/gsi/correlated_obsmod.F90 +++ b/src/gsi/correlated_obsmod.F90 @@ -868,7 +868,7 @@ subroutine upd_varch_ nsat=nsatype(isurf) if (nsat>0) then - do jj0=1,nsat + read_tab: do jj0=1,nsat itbl=tblidx(isurf,jj0) !a row number jc=0 @@ -894,9 +894,9 @@ subroutine upd_varch_ nchanl1=jc if(nchanl1==0) call die(myname_,' improperly set GSI_BundleErrorCov') - if(.not.amiset_(GSI_BundleErrorCov(itbl))) then !KAB + if(.not.amiset_(GSI_BundleErrorCov(itbl))) then if (iamroot_) write(6,*) 'WARNING: Error Covariance not set for ',trim(idnames(itbl)) - return + cycle read_tab endif nch_active=GSI_BundleErrorCov(itbl)%nch_active @@ -989,7 +989,7 @@ subroutine upd_varch_ deallocate(ijac) deallocate(ircv) endif - enddo !jj=1,nsat + enddo read_tab !jj0=1,nsat endif !nsat >0 enddo !isurf=1,5 @@ -997,7 +997,7 @@ subroutine upd_varch_ end subroutine upd_varch_ !EOC -logical function adjust_jac_ (iinstr,nchanl,nsigradjac,ich,varinv,depart, & +logical function adjust_jac_ (iinstr,nchanl,nsigradjac,ich,varinv,depart,obs, & err2,raterr2,wgtjo,jacobian,method,nchasm,rsqrtinv,rinvdiag) !$$$ subprogram documentation block ! . . . @@ -1032,7 +1032,7 @@ logical function adjust_jac_ (iinstr,nchanl,nsigradjac,ich,varinv,depart, & 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) :: depart(nchanl),obs(nchanl) real(r_kind), intent(inout) :: err2(nchanl) real(r_kind), intent(inout) :: raterr2(nchanl) real(r_kind), intent(inout) :: wgtjo(nchanl) @@ -1052,7 +1052,7 @@ logical function adjust_jac_ (iinstr,nchanl,nsigradjac,ich,varinv,depart, & if( GSI_BundleErrorCov(iinstr)%nch_active < 0) return - adjust_jac_ = scale_jac_ (depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & + adjust_jac_ = scale_jac_ (depart,obs,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & ich,nchasm,rsqrtinv,rinvdiag,GSI_BundleErrorCov(iinstr)) method = GSI_BundleErrorCov(iinstr)%method @@ -1066,7 +1066,7 @@ end function adjust_jac_ ! ! !INTERFACE: ! -logical function scale_jac_(depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & +logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & ich,nchasm,rsqrtinv,rinvdiag,ErrorCov) ! !USES: use constants, only: tiny_r_kind @@ -1079,7 +1079,8 @@ logical function scale_jac_(depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & 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) :: depart(:) ! observation-minus-guess departures + real(r_kind),intent(inout) :: obs(:) ! observations 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 @@ -1123,7 +1124,7 @@ logical function scale_jac_(depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & 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(:) :: col,col2 real(r_quad), allocatable,dimension(:,:) :: row real(r_kind), allocatable,dimension(:) :: qcaj real(r_kind), allocatable,dimension(:,:) :: UT @@ -1240,9 +1241,10 @@ logical function scale_jac_(depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & ! structure holding the full covariance nsigjac=size(jacobian,1) allocate(row(nsigjac,ncp)) - allocate(col(ncp)) + allocate(col(ncp),col2(ncp)) row=zero_quad col=zero_quad + col2=zero_quad allocate(qcaj(ncp)) allocate(UT(ncp,ncp)) @@ -1288,6 +1290,7 @@ logical function scale_jac_(depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & do jj=1,ii nn=IJsubset(jj) col(ii) = col(ii) + UT(jj,ii) * depart(nn) + col2(ii) = col2(ii) + UT(jj,ii) * obs(nn) row(:,ii) = row(:,ii) + UT(jj,ii) * jacobian(:,nn) enddo enddo @@ -1296,13 +1299,14 @@ logical function scale_jac_(depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & do jj=1,ncp mm=IJsubset(jj) depart(mm)=col(jj) + obs(mm)=col2(jj) jacobian(:,mm)=row(:,jj) raterr2(mm) = one err2(mm) = one wgtjo(mm) = one enddo - deallocate(col) + deallocate(col,col2) deallocate(row) deallocate(qcaj) deallocate(UT) @@ -1313,7 +1317,7 @@ logical function scale_jac_(depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & mm=IJsubset(jj) raterr2(mm) = raterr2(mm)/ErrorCov%Revals(IRsubset(jj)) err2(mm) = err2(mm) - wgtjo(mm) = varinv(mm)/ErrorCov%Revals(IRsubset(jj)) + wgtjo(mm) = varinv(mm)/ErrorCov%Revals(IRsubset(jj)) enddo diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 68b29b9a45..eee59f23a3 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -43,8 +43,6 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) 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 @@ -318,13 +316,12 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g 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 gridmod, only: eta1_ll,eta2_ll + use constants, only: zero,one,fv,zero_single,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 mpimod, only: mpi_comm_world,mpi_rtype use netcdf_mod, only: nc_check use gsi_rfv3io_mod,only: type_fv3regfilenameg use gsi_rfv3io_mod,only:n2d diff --git a/src/gsi/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index dbf7211e29..d9614b83aa 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -67,6 +67,7 @@ subroutine get_gfs_Nens(this,grd,members,ntindex,atm_bundle,iret) ! 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 +! 2019-09-24 martin - added in support for gfs netCDF IO ! ! input argument list: ! grd - grd info for ensemble @@ -84,7 +85,7 @@ subroutine get_gfs_Nens(this,grd,members,ntindex,atm_bundle,iret) !$$$ use kinds, only: i_kind,r_kind,r_single - use gridmod, only: use_gfs_nemsio + use gridmod, only: use_gfs_nemsio, use_gfs_ncio use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: ens_fast_read use hybrid_ensemble_parameters, only: grd_ens @@ -112,7 +113,7 @@ subroutine get_gfs_Nens(this,grd,members,ntindex,atm_bundle,iret) associate( this => this ) ! eliminates warning for unused dummy argument needed for binding end associate - if ( use_gfs_nemsio .and. ens_fast_read ) then + if ( (use_gfs_nemsio .or. use_gfs_ncio) .and. ens_fast_read ) then 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, & @@ -157,6 +158,8 @@ subroutine get_user_ens_gfs_fastread_(ntindex,en_loc3,m_cvars2d,m_cvars3d, & ! program history log: ! 2016-06-30 mahajan - initial code ! 2016-10-11 parrish - create fast parallel code +! 2019-07-10 zhu - read convective clouds +! 2019-09-24 martin - add in support for use_gfs_ncio ! ! input argument list: ! ntindex - time index for ensemble @@ -182,6 +185,8 @@ subroutine get_user_ens_gfs_fastread_(ntindex,en_loc3,m_cvars2d,m_cvars3d, & use control_vectors, only: nc2d,nc3d !use control_vectors, only: cvars2d,cvars3d use genex_mod, only: genex_info,genex_create_info,genex,genex_destroy_info + use gridmod, only: use_gfs_nemsio + use jfunc, only: cnvw_option implicit none @@ -197,6 +202,7 @@ subroutine get_user_ens_gfs_fastread_(ntindex,en_loc3,m_cvars2d,m_cvars3d, & ! Declare internal variables character(len=*),parameter :: myname_='get_user_ens_gfs_fastread_' character(len=70) :: filename + character(len=70) :: filenamesfc integer(i_kind) :: i,ii,j,jj,k,n integer(i_kind) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens integer(i_kind) :: ip,ips,ipe,jps,jpe @@ -274,15 +280,35 @@ subroutine get_user_ens_gfs_fastread_(ntindex,en_loc3,m_cvars2d,m_cvars3d, & write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas 22 format(a,'sigf',i2.2,'_ens_mem',i3.3) + if (cnvw_option) then + write(filenamesfc,23) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas +23 format(a,'sfcf',i2.2,'_ens_mem',i3.3) + end if + allocate(m_cvars2dw(nc2din),m_cvars3dw(nc3din)) m_cvars2dw=-999 m_cvars3dw=-999 - if ( mas == mae ) & - call parallel_read_nemsio_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & + if ( mas == mae ) then + if ( use_gfs_nemsio ) then + if (cnvw_option) then + call parallel_read_nemsio_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & + ias,jas,mas, & + iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & + filename,.true.,clons,slons,filenamesfc) + else + call parallel_read_nemsio_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & + ias,jas,mas, & + iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & + filename,.true.,clons,slons) + end if + else + call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & ias,jas,mas, & iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename,.true.,clons,slons) + end if + end if base_pe0=-999 if ( mas == 1 .and. mae == 1 ) base_pe0=mype @@ -732,7 +758,7 @@ end subroutine ens_io_partition_ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig, & ias,jas,mas, & iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & - filename,init_head,clons,slons) + filename,init_head,clons,slons,filenamesfc) use kinds, only: i_kind,r_kind,r_single use constants, only: r60,r3600,zero,one,half,pi,deg2rad @@ -742,6 +768,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi use nemsio_module, only: nemsio_getrechead use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use general_sub2grid_mod, only: sub2grid_info + use jfunc, only: cnvw_option implicit none @@ -754,11 +781,12 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi integer(i_kind), intent(inout) :: m_cvars2d(nc2d),m_cvars3d(nc3d) real(r_single), intent(inout) :: en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz) character(len=*), intent(in ) :: filename + character(len=*), optional, intent(in) :: filenamesfc logical, intent(in ) :: init_head real(r_kind), intent(inout) :: clons(nlon),slons(nlon) ! Declare local variables - integer(i_kind) i,ii,j,jj,k,lonb,latb,levs + integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,latb2,lonb2 integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg integer(i_kind) iret @@ -780,8 +808,9 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi real(r_single),allocatable,dimension(:,:,:,:) :: temp3 real(r_kind) :: fhour type(nemsio_gfile) :: gfile + type(nemsio_gfile) :: gfilesfc real(r_kind),allocatable,dimension(:) :: rlats,rlons - real(r_single),allocatable,dimension(:) ::r4lats,r4lons + 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,.true.) @@ -805,6 +834,21 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi call die(myname_, ': ***ERROR*** incorrect resolution',101) endif + if (cnvw_option) then + call nemsio_open(gfilesfc,filenamesfc,'READ',iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filenamesfc),null,'open',istop+2,iret,.true.) + + call nemsio_getfilehead(gfilesfc,iret=iret,dimx=lonb2, dimy=latb2) + if (iret == 0) then + if ( latb2+2 /= nlat .or. lonb2 /=nlon) then + if ( mype == 0 ) & + write(6,*)trim(myname_),': ***ERROR*** incorrect resolution, nlat,nlon=',nlat,nlon, & + ', latb2+2,lonb2=',latb2+2,lonb2 + call die(myname_, ': ***ERROR*** incorrect resolution',101) + endif + endif + endif + ! obtain r4lats,r4lons,rlats,rlons,clons,slons exactly as computed in general_read_gfsatm_nems: allocate(rlats(latb+2),rlons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) @@ -860,6 +904,14 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi work = work + work2 endif endif + if (cnvw_option) then + call nemsio_readrecv(gfilesfc,'cnvcldwat','mid layer',k,work2,iret=iret) + if (iret /= 0) then + call error_msg(trim(myname_),trim(filenamesfc),'cnvcldwat','read',istop+11,iret,.true.) + else + work = work + work2 + end if + end if 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) @@ -964,6 +1016,189 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi end subroutine parallel_read_nemsio_state_ +subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig, & + ias,jas,mas, & + iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & + filename,init_head,clons,slons) +!$$$ subprogram documentation block +! . . . . +! subprogram: parallel_read_gfsnc_state_ read GFS netCDF ensemble member +! prgmmr: Martin org: NCEP/EMC date: 2019-09-24 +! +! program history log: +! 2019-09-24 Martin Initial version. Based on sub parallel_read_nemsio_state_ +! +!$$$ + + use kinds, only: i_kind,r_kind,r_single + use constants, only: r60,r3600,zero,one,half,pi,deg2rad + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use general_sub2grid_mod, only: sub2grid_info + use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + close_dataset, get_dim, read_vardata + + implicit none + + ! Declare local parameters + + ! Declare passed variables + integer(i_kind), intent(in ) :: nlon,nlat,nsig + integer(i_kind), intent(in ) :: ias,jas,mas + integer(i_kind), intent(in ) :: iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz + integer(i_kind), intent(inout) :: m_cvars2d(nc2d),m_cvars3d(nc3d) + real(r_single), intent(inout) :: en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz) + character(len=*), intent(in ) :: filename + logical, intent(in ) :: init_head + real(r_kind), intent(inout) :: clons(nlon),slons(nlon) + + ! Declare local variables + integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,kr + integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf + character(len=120) :: myname_ = 'parallel_read_gfsnc_state_' + real(r_single),allocatable,dimension(:,:,:) :: temp2, rwork3d1, rwork3d2 + real(r_single),allocatable,dimension(:,:) :: rwork2d + real(r_single),allocatable,dimension(:,:,:,:) :: temp3 + real(r_kind),allocatable,dimension(:) :: rlats,rlons + real(r_kind),allocatable,dimension(:) :: rlats_tmp,rlons_tmp + type(Dataset) :: atmges + type(Dimension) :: ncdim + + + atmges = open_dataset(filename) + ! get dimension sizes + ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len + ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + +! check nlat, nlon against latb, lonb + + if ( nlat /= latb+2 .or. nlon /= lonb ) then + if ( mype == 0 ) & + write(6,*)trim(myname_),': ***ERROR*** incorrect resolution, nlat,nlon=',nlat,nlon, & + ', latb+2,lonb=',latb+2,lonb + call die(myname_, ': ***ERROR*** incorrect resolution',101) + endif + +! obtain rlats_tmp,rlons_tnp,rlats,rlons,clons,slons exactly as computed in general_read_gfsatm_nems: + + allocate(rlats(latb+2),rlons(lonb)) + call read_vardata(atmges, 'grid_xt', rlons_tmp) + call read_vardata(atmges, 'grid_yt', rlats_tmp) + do j=1,latb + rlats(latb+2-j)=deg2rad*rlats_tmp(j) + enddo + do j=1,lonb + rlons(j)=deg2rad*rlons_tmp(j) + enddo + deallocate(rlats_tmp,rlons_tmp) + rlats(1)=-half*pi + rlats(latb+2)=half*pi + do j=1,lonb + clons(j)=cos(rlons(j)) + slons(j)=sin(rlons(j)) + enddo + + allocate(rwork3d2(nlon,(nlat-2),nsig)) + allocate(temp3(nlat,nlon,nsig,nc3d)) + allocate(temp2(nlat,nlon,nc2d)) + k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0 + do k3=1,nc3d + if(cvars3d(k3)=='sf') k3u=k3 + if(cvars3d(k3)=='vp') k3v=k3 + if(cvars3d(k3)=='t') k3t=k3 + if(cvars3d(k3)=='q') k3q=k3 + if(cvars3d(k3)=='cw') k3cw=k3 + if(cvars3d(k3)=='oz') k3oz=k3 + if (trim(cvars3d(k3))=='cw') then + call read_vardata(atmges, 'clwmr', rwork3d1) + rwork3d2 = 0 + call read_vardata(atmges, 'icmr', rwork3d2) + rwork3d1 = rwork3d1 + rwork3d2 + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do + else if(trim(cvars3d(k3))=='oz') then + call read_vardata(atmges, 'o3mr', rwork3d1) + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do + else if(trim(cvars3d(k3))=='q') then + call read_vardata(atmges, 'spfh', rwork3d1) + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do + else if(trim(cvars3d(k3))=='t') then + call read_vardata(atmges, 'tmp', rwork3d1) + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do + else if(trim(cvars3d(k3))=='sf') then + call read_vardata(atmges, 'ugrd', rwork3d1) + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do + else if(trim(cvars3d(k3))=='vp') then + call read_vardata(atmges, 'vgrd', rwork3d1) + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do + end if + enddo + if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3cw==0.or.k3oz==0) & + write(6,'(" WARNING, problem with one of k3-")') + + temp2=zero + do k2=1,nc2d + if(trim(cvars2d(k2))=='ps') then + call read_vardata(atmges, 'pressfc', rwork2d) + call move1_(rwork2d,temp2(:,:,k2),nlon,nlat) + endif + enddo + deallocate(rwork2d, rwork3d1) + deallocate(rwork3d2) + +! move temp2,temp3 to en_full + kf=0 + do k3=1,nc3d + m_cvars3d(k3)=kf+1 + do k=1,nsig + kf=kf+1 + jj=jas-1 + do j=1,nlon + jj=jj+1 + ii=ias-1 + do i=1,nlat + ii=ii+1 + en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) + enddo + enddo + enddo + enddo + do k2=1,nc2d + m_cvars2d(k2)=kf+1 + kf=kf+1 + jj=jas-1 + do j=1,nlon + jj=jj+1 + ii=ias-1 + do i=1,nlat + ii=ii+1 + en_full(ii,jj,kf,mas)=temp2(i,j,k2) + enddo + enddo + enddo + + deallocate(temp3) + deallocate(temp2) + +end subroutine parallel_read_gfsnc_state_ + subroutine fillpoles_s_(temp,nlon,nlat) !$$$ subprogram documentation block ! . . . . @@ -1143,6 +1378,7 @@ subroutine get_gfs_ens(this,grd,member,ntindex,atm_bundle,iret) ! program history log: ! 2016-06-30 mahajan - initial code ! 2019-03-13 eliu - add precipitation component +! 2019-09-24 martin - added option for use_gfs_ncio ! ! input argument list: ! grd - grd info for ensemble @@ -1160,7 +1396,7 @@ subroutine get_gfs_ens(this,grd,member,ntindex,atm_bundle,iret) !$$$ use kinds, only: i_kind,r_kind - use gridmod, only: use_gfs_nemsio + use gridmod, only: use_gfs_nemsio, use_gfs_ncio use general_sub2grid_mod, only: sub2grid_info use gsi_4dvar, only: ens_fhrlevs use hybrid_ensemble_parameters, only: ensemble_path @@ -1206,9 +1442,12 @@ subroutine get_gfs_ens(this,grd,member,ntindex,atm_bundle,iret) else call general_read_gfsatm_nems(grd,sp_ens,filename,uv_hyb_ens,.false., & - zflag,atm_bundle,.true.,iret) + zflag,atm_bundle,.true.,iret,ntindex) endif + else if ( use_gfs_ncio ) then + call general_read_gfsatm_nc(grd,sp_ens,filename,uv_hyb_ens,.false., & + zflag,atm_bundle,.true.,iret) else call general_read_gfsatm(grd,sp_ens,sp_ens,filename,uv_hyb_ens,.false., & zflag,atm_bundle,inithead,iret) @@ -1238,6 +1477,7 @@ subroutine put_gfs_ens(this,grd,member,ntindex,pert,iret) ! program history log: ! 2016-06-30 mahajan - initial code ! 2016-07-20 mpotts - refactored into class/module +! 2019-09-24 martin - stub for use_gfs_ncio ! ! input argument list: ! grd - grd info for ensemble @@ -1260,7 +1500,7 @@ subroutine put_gfs_ens(this,grd,member,ntindex,pert,iret) use gsi_4dvar, only: ens_fhrlevs use hybrid_ensemble_parameters, only: ensemble_path use hybrid_ensemble_parameters, only: sp_ens - use gridmod, only: use_gfs_nemsio + use gridmod, only: use_gfs_nemsio, use_gfs_ncio implicit none @@ -1291,6 +1531,12 @@ subroutine put_gfs_ens(this,grd,member,ntindex,pert,iret) iret = 999 endif !call write_nemsatm(grd,...) + else if ( use_gfs_ncio ) then + if ( mype == 0 ) then + write(6,*) 'write_gfsncatm is not adapted to write out perturbations yet' + iret = 999 + endif + !call write_gfsncatm(grd,...) else call general_write_gfsatm(grd,sp_ens,sp_ens,filename,mype_atm, & pert,ntindex,inithead,iret) diff --git a/src/gsi/cplr_gfs_nstmod.f90 b/src/gsi/cplr_gfs_nstmod.f90 index 1f08aa0333..b482085aac 100644 --- a/src/gsi/cplr_gfs_nstmod.f90 +++ b/src/gsi/cplr_gfs_nstmod.f90 @@ -51,8 +51,9 @@ end subroutine nst_init_ subroutine nst_read_(mype_io) use kinds, only: i_kind - use gridmod, only: use_gfs_nemsio + use gridmod, only: use_gfs_nemsio, use_gfs_ncio use ncepgfs_io, only: read_gfsnst + use netcdfgfs_io, only: read_gfsncnst use ncepnems_io, only: read_nemsnst 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 @@ -62,6 +63,9 @@ subroutine nst_read_(mype_io) if ( use_gfs_nemsio ) then call read_nemsnst(mype_io,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) + else if ( use_gfs_ncio ) then + call read_gfsncnst(mype_io,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) else call read_gfsnst(mype_io,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) diff --git a/src/gsi/crtm_interface.f90 b/src/gsi/crtm_interface.f90 index 6a3048e9d9..6e5d775c9c 100644 --- a/src/gsi/crtm_interface.f90 +++ b/src/gsi/crtm_interface.f90 @@ -116,7 +116,7 @@ module crtm_interface 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 iclr_sky ! = 7 index of clear sky amount (goes_img, seviri,abi,ahi) 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) @@ -528,7 +528,8 @@ subroutine init_crtm(init_pass,mype_diaghdr,mype,nchanl,nreal,isis,obstype,radmo itz_tr = nreal ! index of d(Tz)/d(Tr) - if (obstype == 'goes_img' .or. obstype == 'abi') then + if (obstype == 'goes_img' .or. obstype == 'abi' & + .or. obstype == 'ahi' .or. obstype == 'seviri' ) then iclr_sky = 7 ! index of clear sky amount elseif (obstype == 'avhrr_navy') then isst_navy = 7 ! index of navy sst (K) retrieval @@ -537,8 +538,6 @@ subroutine init_crtm(init_pass,mype_diaghdr,mype,nchanl,nreal,isis,obstype,radmo 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 @@ -1570,8 +1569,8 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & ! 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 - + if(obstype == 'goes_img' .or. obstype == 'seviri' .or. obstype == 'abi' & + .or. obstype == 'ahi' )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 diff --git a/src/gsi/general_read_gfsatm.f90 b/src/gsi/general_read_gfsatm.f90 index c73638b148..2ac8bfe596 100755 --- a/src/gsi/general_read_gfsatm.f90 +++ b/src/gsi/general_read_gfsatm.f90 @@ -761,7 +761,7 @@ subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & end subroutine general_read_gfsatm subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & - gfs_bundle,init_head,iret_read) + gfs_bundle,init_head,iret_read,it) !$$$ subprogram documentation block ! . . . . ! subprogram: general_read_gfsatm adaptation of read_gfsatm for general resolutions @@ -779,6 +779,7 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! internal code should be generalized ! 2014-12-03 derber - introduce vordivflag, zflag and optimize routines ! 2019-06-06 eliu - add cloud fraction +! 2019-07-10 zhu - add convective clouds ! ! input argument list: ! grd - structure variable containing information about grid @@ -819,7 +820,9 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & use constants, only: two,pi,half,deg2rad,r60,r3600 use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer + use jfunc, only: cnvw_option use gfsreadmod, only: general_reload + use guess_grids, only: ifilesfc implicit none @@ -831,6 +834,7 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & type(spec_vars) ,intent(in ) :: sp_a character(*) ,intent(in ) :: filename logical ,intent(in ) :: uvflag,zflag,vordivflag,init_head + integer(i_kind) ,intent(in ) :: it integer(i_kind) ,intent( out) :: iret_read type(gsi_bundle) ,intent(inout) :: gfs_bundle @@ -845,12 +849,14 @@ 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=24) :: filenamesfc 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 integer(i_kind) :: latb, lonb, levs, nframe + integer(i_kind) :: latb2, lonb2 integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd integer(i_kind) :: istop = 101 integer(i_kind),dimension(npe)::ilev,iflag,mype_use @@ -870,6 +876,7 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & logical :: procuse,diff_res,eqspace,has_cf character(nemsio_charkind),allocatable:: recname(:) type(nemsio_gfile) :: gfile + type(nemsio_gfile) :: gfilesfc type(egrid2agrid_parm) :: p_high logical,dimension(1) :: vector @@ -954,6 +961,28 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & call stop2(101) endif + if (cnvw_option) then + write(filenamesfc,'(''sfcf'',i2.2)') ifilesfc(it) + call nemsio_open(gfilesfc,filenamesfc,'READ',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filenamesfc),null,'open',istop+2,iret) + + call nemsio_getfilehead(gfilesfc,iret=iret,dimx=lonb2, dimy=latb2) + if (iret == 0) then + if ( latb2 /= nlatm2 ) then + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlatm2 = '',i4,tr1,''latb2 ='',i4)') & + trim(my_name),nlatm2,latb2 + call stop2(101) + endif + if ( lonb2 /= grd%nlon ) then + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlon = '',i4,tr1,''lonb2 ='',i4)') & + trim(my_name),grd%nlon,lonb2 + call stop2(101) + endif + endif + end if + 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 @@ -1457,6 +1486,14 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & rwork1d0 = rwork1d0 + rwork1d1 endif endif + if (cnvw_option) then + call nemsio_readrecv(gfilesfc,'cnvcldwat','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) then + call error_msg(trim(my_name),trim(filenamesfc),'cnvcldwat','read',istop+11,iret) + else + rwork1d0 = rwork1d0 + rwork1d1 + endif + endif if ( diff_res ) then grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) vector(1)=.false. @@ -1524,6 +1561,10 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & 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) + if (cnvw_option) then + call nemsio_close(gfilesfc,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filenamesfc),null,'close',istop+10,iret) + end if endif deallocate(work) @@ -1571,7 +1612,7 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! Print date/time stamp if ( mype == 0 ) then write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& - fhour,odate,trim(filename) + fhour,odate,filename(1:24) 700 format('GENERAL_READ_GFSATM_NEMS: read lonb,latb,levs=',& 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) endif @@ -1580,6 +1621,715 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & end subroutine general_read_gfsatm_nems +subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & + gfs_bundle,init_head,iret_read) +!$$$ subprogram documentation block +! . . . . +! subprogram: general_read_gfsatm_nc adaptation of read_gfsatm for general resolutions +! prgmmr: martin org: NCEP/EMC date: 2019-09-25 +! +! abstract: copied from read_gfsatm_nems +! +! program history log: +! 2019-09-25 martin - original; copied from general_read_gfsatm_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) +! sp_b - structure variable containing spectral information for input +! fields +! (initialized by general_init_spec_vars, located in general_specmod.f90) +! filename - input netcdf 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 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 module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + close_dataset, get_dim, read_vardata,get_idate_from_time_units + use gfsreadmod, only: general_reload + + 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_cwmr,g_q,g_oz,g_tv + + 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_GFSATM_NC' + integer(i_kind):: iret,nlatm2,nlevs,icm,nord_int + integer(i_kind):: i,j,k,icount,kk,kr + integer(i_kind) :: ier,istatus,iredundant + integer(i_kind) :: latb, lonb, levs + integer(i_kind),dimension(npe)::ilev,iflag,mype_use + integer(i_kind),dimension(6):: idate + integer(i_kind),dimension(4):: odate + real(r_kind),allocatable,dimension(:) :: 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_single),allocatable,dimension(:,:,:) :: rwork3d0, rwork3d1 + real(r_single),allocatable,dimension(:,:) :: rwork2d + real(r_kind),allocatable,dimension(:) :: work, work_v + real(r_kind),allocatable,dimension(:) :: rlats,rlons,clons,slons + real(r_kind),allocatable,dimension(:) :: rlats_tmp,rlons_tmp + + logical :: procuse,diff_res,eqspace + type(egrid2agrid_parm) :: p_high + logical,dimension(1) :: vector + type(Dataset) :: atmges + type(Dimension) :: ncdim + + + + !****************************************************************************** + ! 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 + + atmges = open_dataset(filename, paropen=.true.) + + ! get dimension sizes + ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len + ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + + ! get time information + idate = get_idate_from_time_units(atmges) + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later + ! depends on model changes from + ! Jeff Whitaker + fhour = float(nint(fhour)) + + 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(rwork3d0(lonb,latb,1)) + allocate(rwork3d1(lonb,latb,1)) + allocate(rwork2d(lonb,latb)) + allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb)) + call read_vardata(atmges, 'grid_xt', rlons_tmp) + call read_vardata(atmges, 'grid_yt', rlats_tmp) + do j=1,latb + rlats(latb+2-j)=deg2rad*rlats_tmp(j) + end do + do j=1,lonb + rlons(j)=deg2rad*rlons_tmp(j) + end do + deallocate(rlats_tmp,rlons_tmp) + 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_gfsatm_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_gfsatm_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_gfsatm_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,'cw',g_cwmr,ier);istatus=istatus+ier + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nems: ERROR' + write(6,*) 'Missing some of the required fields' + 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 read_vardata(atmges, 'hgtsfc', rwork2d) + if ( diff_res ) then + grid_b=rwork2d + 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=rwork2d + call general_fill_ns(grd,grid,work) + 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) + 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 read_vardata(atmges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + 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=rwork2d + call general_fill_ns(grd,grid,work) + 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) + 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 + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(atmges, 'spfh', rwork3d1, nslice=kr, slicedim=3) + call read_vardata(atmges, 'tmp', rwork3d0, nslice=kr, slicedim=3) + rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) + if ( diff_res ) then + grid_b=rwork2d + 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=rwork2d + call general_fill_ns(grd,grid,work) + 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) + endif + end do + + if ( vordivflag .or. .not. uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=4 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Vorticity + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + 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 = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + 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_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 + + end do + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=5 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Divergence + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + 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 = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + 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_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 + + end do + endif ! if ( vordivflag .or. .not. uvflag ) + if ( uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=6 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + 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 = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + 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) + endif + + icount=icount+1 + iflag(icount)=7 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! V + call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + 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 = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + ! 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_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 + end do + endif ! if ( uvflag ) + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=8 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Specific humidity + call read_vardata(atmges, 'spfh', rwork3d0, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + 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 = rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + 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) + endif + end do + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=9 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(atmges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) + ! Ozone mixing ratio + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + 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=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + 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) + endif + end do + + do k=1,nlevs + icount=icount+1 + iflag(icount)=10 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(atmges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(atmges, 'icmr', rwork3d1, nslice=kr, slicedim=3) + ! Cloud condensate mixing ratio. + rwork2d = rwork3d0(:,:,1)+rwork3d1(:,:,1) + if ( diff_res ) then + grid_b=rwork2d + 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=rwork2d + 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) + 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(rwork3d1,rwork3d0,clons,slons) + deallocate(rwork2d) + deallocate(grid,grid_v) + call close_dataset(atmges) + endif + deallocate(work) + + ! 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_GFSATM_NC: read lonb,latb,levs=',& + 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) + endif + + return + +end subroutine general_read_gfsatm_nc + subroutine general_fill_ns(grd,grid_in,grid_out) ! !USES: diff --git a/src/gsi/genstats_gps.f90 b/src/gsi/genstats_gps.f90 index 13e2b4be41..4db3965c41 100644 --- a/src/gsi/genstats_gps.f90 +++ b/src/gsi/genstats_gps.f90 @@ -259,7 +259,6 @@ subroutine genstats_gps(bwork,awork,toss_gps_sub,conv_diagsave,mype) 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 @@ -291,8 +290,6 @@ subroutine genstats_gps(bwork,awork,toss_gps_sub,conv_diagsave,mype) 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 @@ -741,7 +738,12 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + nnz = 3*nsig + nind = 3 + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ @@ -787,8 +789,9 @@ subroutine contents_netcdf_diag_ 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) + call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind(1:dhx_dx%nind)) + call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind(1:dhx_dx%nind)) + call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val(1:dhx_dx%nnz),r_single)) endif diff --git a/src/gsi/gesinfo.f90 b/src/gsi/gesinfo.F90 similarity index 86% rename from src/gsi/gesinfo.f90 rename to src/gsi/gesinfo.F90 index 871830a3ea..136271aae0 100644 --- a/src/gsi/gesinfo.f90 +++ b/src/gsi/gesinfo.F90 @@ -34,6 +34,7 @@ subroutine gesinfo ! 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 +! 2019-09-24 martin - add use_gfs_ncio if input files are in netCDF format ! ! input argument list: ! @@ -78,11 +79,14 @@ subroutine gesinfo 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, & - regional_fmin + regional_fmin, use_gfs_ncio 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,nemsio_getheadvar + use module_fv3gfs_ncio, only: Dimension, Dataset, open_dataset, get_dim, & + read_vardata, get_idate_from_time_units,& + read_attribute, close_dataset use constants, only: zero,h300,r60,r3600,i_missing @@ -103,25 +107,30 @@ subroutine gesinfo ! Declare local variables logical fexist - character(6) filename + character(6) filename,sfilename character(8) filetype, mdlname - integer(i_kind) iyr,ihourg,k + integer(i_kind) iyr,ihourg,k,kr integer(i_kind) mype_out,iret,iret2,intype 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),dimension(6):: idate2 integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind),allocatable,dimension(:) :: ntrac,ncld real(r_kind) hourg, minuteg real(r_kind),dimension(5) :: fha real(r_single),allocatable,dimension(:,:,:) :: nems_vcoord + real(r_single),allocatable,dimension(:) :: aknc, bknc, fhour type(sigio_head):: sighead type(ncepgfs_head):: gfshead type(ncepgfs_headv):: gfsheadv type(nemsio_gfile) :: gfile2 + type(Dataset) :: atmges,sfcges + type(Dimension) :: ncdim logical :: print_verbose logical :: fatal = .false. @@ -166,7 +175,7 @@ subroutine gesinfo ! Determine NCEP atmospheric guess file format intype = 0 - if ( .not. use_gfs_nemsio ) then + if ( (.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio) ) then call sigio_sropen(lunges,filename,iret) call sigio_srhead(lunges,sighead,iret2) @@ -219,7 +228,7 @@ subroutine gesinfo ! Extract information from NCEP atmospheric guess using NEMSIO - else + else if ( use_gfs_nemsio ) then call nemsio_init(iret=iret2) if ( iret2 /= 0 ) then write(6,*)' GESINFO: ***ERROR*** problem nemsio_init file = ', & @@ -325,6 +334,51 @@ subroutine gesinfo ! ' user (nlat,nlon,nsig)=',nlat,nlon,nsig ! call stop2(99) ! endif + else ! use_gfs_ncio and get this information + write(sfilename,'("sfcf",i2.2)')nhr_assimilation + ! open the netCDF file + atmges = open_dataset(filename) + sfcges = open_dataset(sfilename) + ! get dimension sizes + ncdim = get_dim(atmges, 'grid_xt'); gfshead%lonb = ncdim%len + ncdim = get_dim(atmges, 'grid_yt'); gfshead%latb = ncdim%len + ncdim = get_dim(atmges, 'pfull') ; gfshead%levs = ncdim%len + ! hard code jcap,idsl,idvc + gfshead%jcap = -9999 + gfshead%idsl= 1 + gfshead%idvc = 2 + call read_attribute(atmges, 'ncnsto', ntrac) + gfshead%ntrac = ntrac(1) + call read_attribute(sfcges, 'ncld', ncld) + gfshead%ncldt = ncld(1) + call close_dataset(sfcges) + if (mype==mype_out) write(6,*)'GESINFO: Read NCEP FV3GFS netCDF ', & + 'format file, ',trim(filename) + ! hard code nvcoord to be 2 + gfshead%nvcoord=2 ! ak and bk + if (allocated(gfsheadv%vcoord)) deallocate(gfsheadv%vcoord) + allocate(gfsheadv%vcoord(gfshead%levs+1,gfshead%nvcoord)) + call read_attribute(atmges, 'ak', aknc) + call read_attribute(atmges, 'bk', bknc) + do k=1,gfshead%levs+1 + kr = gfshead%levs+2-k + gfsheadv%vcoord(k,1) = aknc(kr) + gfsheadv%vcoord(k,2) = bknc(kr) + end do + deallocate(aknc,bknc) + + ! get time information + idate2 = get_idate_from_time_units(atmges) + gfshead%idate(1) = idate2(4) !hour + gfshead%idate(2) = idate2(2) !month + gfshead%idate(3) = idate2(3) !day + gfshead%idate(4) = idate2(1) !year + call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later + ! depends on model changes from Jeff Whitaker + gfshead%fhour = fhour(1) + + call close_dataset(atmges) + endif ! Extract header information @@ -333,6 +387,7 @@ subroutine gesinfo idate4(2)= gfshead%idate(2) idate4(3)= gfshead%idate(3) idate4(4)= gfshead%idate(4) + idate4(5)= zero ntracer = gfshead%ntrac ncloud = gfshead%ncldt @@ -371,7 +426,7 @@ subroutine gesinfo tref5(k)=h300 end do - if ( .not. use_gfs_nemsio ) then + if ( (.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio) ) then ! Load surface pressure and thermodynamic variable ids idvm5 = gfshead%idvm idpsfc5 = mod ( gfshead%idvm,10 ) @@ -415,7 +470,7 @@ subroutine gesinfo ! Echo select header information to stdout if(mype==mype_out .and. print_verbose) then - if ( .not. use_gfs_nemsio ) then + if ( (.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio) ) then write(6,100) gfshead%jcap,gfshead%levs,gfshead%latb,gfshead%lonb,& gfshead%ntrac,gfshead%ncldt,idvc5,gfshead%nvcoord,& idvm5,idsl5,idpsfc5,idthrm5 @@ -461,23 +516,27 @@ 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 +#ifdef RR_CLOUDANALYSIS + fha(3)=minuteg ! relative time interval in minutes +#endif 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 +#ifdef RR_CLOUDANALYSIS + ida(6)=idate4(5) ! minute +#endif 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 - if(regional) then - iadate(5)=jda(6) !regional_time(5) ! minute - else - iadate(5)=0 ! minute - end if +#ifdef RR_CLOUDANALYSIS + iadate(5)=jda(6) !regional_time(5) ! minute +#else + iadate(5)=0 ! minute +#endif ianldate =jda(1)*1000000+jda(2)*10000+jda(3)*100+jda(5) ! Determine date and time at start of assimilation window @@ -514,11 +573,11 @@ subroutine gesinfo ! Get time offset call time_4dvar(ianldate,time_offset) - if (regional)then - fha(2)=float(int(min_offset/60)) - fha(3)=(min_offset-fha(2)*r60) - time_offset=time_offset+fha(3)/r60 - endif +#ifdef RR_CLOUDANALYSIS + fha(2)=float(int(min_offset/60)) + fha(3)=(min_offset-fha(2)*r60) + time_offset=time_offset+fha(3)/r60 +#endif ! Get information about date/time and number of guess files if (regional) then diff --git a/src/gsi/gfs_stratosphere.f90 b/src/gsi/gfs_stratosphere.f90 index b2278104d6..6d6a3de433 100644 --- a/src/gsi/gfs_stratosphere.f90 +++ b/src/gsi/gfs_stratosphere.f90 @@ -146,6 +146,7 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt ! 2012-10-11 eliu - modify to work for wrf_nmm_regional (HWRF) ! 2013-02-15 parrish - change dimension of eta1, eta2, eta1m, eta2m to correct value. ! 2016-12-06 tong - add code to get gfs nemsio meta data, if use_gfs_nemsio=True +! 2019-09-24 martin - add code to get fv3gfs netCDF info, if use_gfs_ncio=True ! ! input argument list: ! deta1 - all of these are original nmmb vertical coordinate specifications. @@ -176,10 +177,13 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt use sigio_module, only: sigio_intkind,sigio_head,sigio_srhead use constants, only: zero,one_tenth,half,one,ten,r0_01,r60,r3600 use blendmod, only: init_blend,blend_f,blend_df - use gridmod, only: use_gfs_nemsio + use gridmod, only: use_gfs_nemsio,use_gfs_ncio use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close use ncepnems_io, only: error_msg use nemsio_module, only: nemsio_gfile,nemsio_getfilehead + use module_fv3gfs_ncio, only: Dataset, Dimension, get_dim, read_vardata,& + open_dataset, close_dataset, read_attribute,& + get_idate_from_time_units implicit none @@ -196,7 +200,7 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt real(r_kind) ak_r(nsigr+1),bk_r(nsigr+1),p_r(nsigr+1) real(r_kind),dimension(:),allocatable:: p_g,dp_g ! (nsigg+1) real(r_kind) psfc - integer(i_kind) k + integer(i_kind) k,kr real(r_kind) dp_r(nsigr+1) real(r_kind) pref0,pref1 real(r_kind) delpmin,delp @@ -222,19 +226,23 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd integer(i_kind) :: istop = 101 integer(i_kind),dimension(7):: idate + integer(i_kind),dimension(6):: idate6 real(r_kind) :: fhour type(nemsio_gfile) :: gfile integer(i_kind) :: nvcoord real(r_single),allocatable:: nems_vcoord(:,:,:) real(r_single),allocatable:: vcoord(:,:) logical print_verbose + type(Dataset) :: atmges + type(Dimension) :: ncdim + real(r_kind), allocatable, dimension(:) :: fhour2,aknc,bknc print_verbose=.false. if(verbose)print_verbose=.true. ! First, obtain gfs vertical coordinate information: filename='gfs_sigf03' - if (.not. use_gfs_nemsio)then + if ((.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio))then open(lunges,file=trim(filename),form='unformatted') call sigio_srhead(lunges,sighead,iret) close(lunges) @@ -252,6 +260,39 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt write(6,*)' MIX_GFS_NMMB_VCOORDS: NOT READY YET FOR ak5,bk5,ck5 vert coordinate' call stop2(85) endif + else if (use_gfs_ncio) then + atmges = open_dataset(filename) + ! get dimension sizes + ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len + ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + + ! get time information + idate6 = get_idate_from_time_units(atmges) + call read_vardata(atmges, 'time', fhour2) ! might need to change this to attribute later + ! depends on model changes from Jeff Whitaker + fhour = fhour2(1) + write(6,*) ' input filename=',filename + write(6,*) ' netcdf info: fhour,idate=',fhour,idate6 + write(6,*) ' netcdf info: levs=',levs + + nvcoord=2 ! ak and bk + allocate(vcoord(levs+1,nvcoord)) + call read_attribute(atmges, 'ak', aknc) + call read_attribute(atmges, 'bk', bknc) + do k=1,levs+1 + kr = levs+2-k + vcoord(k,1) = aknc(kr) + vcoord(k,2) = bknc(kr) + end do + if(print_verbose)then + write(6,*) ' netcdf : nvcoord=', nvcoord + do k=1,levs+1 + write(6,*)' k,vcoord=',k,vcoord(k,:) + enddo + end if + call close_dataset(atmges) + else call nemsio_init(iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),' ','init',istop,iret) @@ -318,6 +359,8 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt if (allocated(dpref_m)) deallocate(dpref_m) if (allocated(ak_m)) deallocate(ak_m) if (allocated(bk_m)) deallocate(bk_m) + if (allocated(aknc)) deallocate(aknc) + if (allocated(bknc)) deallocate(bknc) if (allocated(akm)) deallocate(akm) if (allocated(bkm)) deallocate(bkm) if (allocated(plotp)) deallocate(plotp) @@ -332,7 +375,7 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt if (allocated(ak5)) deallocate(ak5) if (allocated(bk5)) deallocate(bk5) - if(.not. use_gfs_nemsio)then + if((.not. use_gfs_nemsio).and.(.not. use_gfs_ncio))then nsigg=sighead%levs else nsigg=levs @@ -346,7 +389,7 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt ak5(k)=zero bk5(k)=zero end do - if (.not. use_gfs_nemsio)then + if ((.not. use_gfs_nemsio).and.(.not. use_gfs_ncio))then do k = 1,nsigg+1 ak5(k) = sighead%vcoord(k,1)*zero_001 ! for purpose of this routine, convert to mb @@ -807,6 +850,7 @@ subroutine add_gfs_stratosphere ! 2014-12-03 derber - modify call to general_read_gfsatm to reduce reading ! of unused variables ! 2016-12-10 tong - add code to gfs nemsio meta data, if use_gfs_nemsio=True +! 2019-09-24 martin - add support for when use_gfs_ncio is True ! ! input argument list: ! @@ -818,7 +862,7 @@ subroutine add_gfs_stratosphere ! !$$$ enddocumentation block - use gridmod, only: regional,wrf_nmm_regional,use_gfs_nemsio + use gridmod, only: regional,wrf_nmm_regional,use_gfs_nemsio,use_gfs_ncio use gridmod, only: region_lat,region_lon,aeta1_ll,aeta2_ll,pdtop_ll,pt_ll use gridmod, only: nlon,nlat,lat2,lon2,nsig,rotate_wind_ll2xy use gridmod, only: use_gfs_ozone,jcap_gfs,nlat_gfs,nlon_gfs @@ -855,6 +899,9 @@ subroutine add_gfs_stratosphere use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close use ncepnems_io, only: error_msg use nemsio_module, only: nemsio_gfile,nemsio_getfilehead + use module_fv3gfs_ncio, only: Dataset,Dimension,open_dataset,close_dataset,& + read_attribute,get_dim,read_vardata,& + get_idate_from_time_units implicit none @@ -939,6 +986,13 @@ subroutine add_gfs_stratosphere real(r_kind),pointer,dimension(:,:,:):: ges_qh logical print_verbose + ! variables for netcdf io + type(Dataset) :: atmges + type(Dimension) :: ncdim + integer(i_kind),dimension(6):: idate6 + real(r_kind),allocatable,dimension(:) :: fhour2 + + ! allocate space for saving original regional model guess and original blended regional-global guess: allocate(ges_tv_r_g(lat2,lon2,nsig,nfldsig)) @@ -1084,7 +1138,7 @@ subroutine add_gfs_stratosphere filename=infiles(it) if (mype==0) write(6,*)'add_gfs_stratosphere: reading in gfs file: ',trim(filename) - if ( .not. use_gfs_nemsio ) then + if ( (.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio) ) then open(lunges,file=trim(filename),form='unformatted') call sigio_srhead(lunges,sighead,iret) close(lunges) @@ -1094,6 +1148,18 @@ subroutine add_gfs_stratosphere write(6,*) ' sighead%latf,sighead%lonf=',sighead%latf,sighead%lonf endif jcap_org=sighead%jcap + else if (use_gfs_ncio) then + atmges = open_dataset(filename) + ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len + ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + njcap = -9999 + jcap_org = njcap + idate6 = get_idate_from_time_units(atmges) + call read_vardata(atmges, 'time', fhour2) + fhour = fhour2(1) + call close_dataset(atmges) + else call nemsio_init(iret=iret) if (iret /= 0) call error_msg(trim(my_name),trim(filename),' ','init',istop,iret) @@ -1127,12 +1193,18 @@ subroutine add_gfs_stratosphere end if ! Extract header information - if(.not. use_gfs_nemsio)then + if((.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio))then hourg = sighead%fhour idate4(1)= sighead%idate(1) idate4(2)= sighead%idate(2) idate4(3)= sighead%idate(3) idate4(4)= sighead%idate(4) + else if (use_gfs_ncio) then + hourg = fhour + idate4(1) = idate6(4) !hour + idate4(2) = idate6(2) !month + idate4(3) = idate6(3) !day + idate4(4) = idate6(1) !year else hourg = fhour idate4(1) = idate(4) !hour @@ -1189,7 +1261,7 @@ subroutine add_gfs_stratosphere hires=.true. else hires=.false. - if(.not. use_gfs_nemsio)then + if((.not. use_gfs_nemsio).and.(.not. use_gfs_ncio))then jcap_gfs=sighead%jcap nlat_gfs=sighead%latf+2 nlon_gfs=sighead%lonf @@ -1218,7 +1290,7 @@ subroutine add_gfs_stratosphere .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) - if ( hires .and. .not. use_gfs_nemsio ) call general_init_spec_vars(sp_b,jcap_org,jcap_org,nlat_gfs,nlon_b) + if ( hires .and. .not. use_gfs_nemsio .and. .not. use_gfs_ncio) call general_init_spec_vars(sp_b,jcap_org,jcap_org,nlat_gfs,nlon_b) ! 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. @@ -1238,6 +1310,9 @@ subroutine add_gfs_stratosphere if ( use_gfs_nemsio ) then call general_read_gfsatm_nems(grd_gfst,sp_gfs,filename,.true.,.false.,.true., & atm_bundle,.true.,iret) + else if (use_gfs_ncio) then + call general_read_gfsatm_nc(grd_gfst,sp_gfs,filename,.true.,.false.,.true., & + atm_bundle,.true.,iret) else if ( hires ) then call general_read_gfsatm(grd_gfst,sp_gfs,sp_b,filename,.true.,.false.,.true., & @@ -1837,7 +1912,7 @@ subroutine add_gfs_stratosphere endif call general_destroy_spec_vars(sp_gfs) - if ( hires .and. .not. use_gfs_nemsio ) call general_destroy_spec_vars(sp_b) + if ( hires .and. .not. use_gfs_nemsio .and. .not. use_gfs_ncio) call general_destroy_spec_vars(sp_b) deallocate(xspli_r,yspliu_r,yspliv_r,xsplo) deallocate(ysplou_r,ysplov_r,ysplou_g,ysplov_g) deallocate(xspli_g,yspliu_g,yspliv_g) diff --git a/src/gsi/gridmod.F90 b/src/gsi/gridmod.F90 index 0691095852..fea4a06059 100644 --- a/src/gsi/gridmod.F90 +++ b/src/gsi/gridmod.F90 @@ -89,6 +89,8 @@ module gridmod ! 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 +! 2019-09-04 martin - add write_fv3_incr to write netCDF increment rather than analysis in NEMSIO format +! 2019-09-23 martin - add use_gfs_ncio to read global first guess from netCDF file ! ! ! @@ -149,6 +151,7 @@ module gridmod public :: jcap,jcap_b,hires_b,sp_a,grd_a public :: jtstart,jtstop,nthreads public :: use_gfs_nemsio + public :: use_gfs_ncio public :: fv3_full_hydro public :: use_fv3_aero public :: sfcnst_comb @@ -156,6 +159,7 @@ module gridmod public :: jcap_gfs,nlat_gfs,nlon_gfs public :: use_sp_eqspace,jcap_cut public :: wrf_mass_hybridcord + public :: write_fv3_incr interface strip module procedure strip_single_rank33_ @@ -187,10 +191,12 @@ 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 use_gfs_ncio ! .t. for using netCDF 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 write_fv3_incr ! .t. write netCDF increment rather than NEMSIO analysis 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 @@ -405,6 +411,7 @@ subroutine init_grid ! 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 +! 2019-09-23 martin - add flag use_gfs_ncio to determine whether to use netCDF to read global first gues field ! ! !REMARKS: ! language: f90 @@ -482,6 +489,7 @@ subroutine init_grid nthreads = 1 ! initialize the number of threads use_gfs_nemsio = .false. + use_gfs_ncio = .false. fv3_full_hydro = .false. use_fv3_aero = .false. sfcnst_comb = .false. @@ -1092,6 +1100,7 @@ subroutine init_reg_glob_ll(mype,lendian_in) 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 + pt_ll=zero endif ! fv3_regional if(wrf_nmm_regional) then ! begin wrf_nmm section diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 28cb996582..c0366c9b3d 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -575,7 +575,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) !$$$ end documentation block use kinds, only: r_kind,i_kind use mpimod, only: npe - use guess_grids, only: nfldsig,ges_tsen,ges_prsi + use guess_grids, only: 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 @@ -920,7 +920,7 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io) 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 gridmod, only: lat2,lon2,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 @@ -2072,9 +2072,9 @@ subroutine gsi_fv3ncdf_writeps_v1(filename,varname,var,mype_io,add_saved) !$$$ 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: lat2,lon2,nlon,nlat,lat1,lon1 use gridmod, only: ijn,displs_g,itotsub,iglobal - use gridmod, only: nlon_regional,nlat_regional,eta1_ll,eta2_ll + use gridmod, only: nlon_regional,nlat_regional 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 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 3f7f4bf976..d13c2e733c 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -87,18 +87,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,vadwnd_l2rw_qc, & + buddycheck_t,buddydiag_save,njqc,vqc,nvqc,hub_norm,vadwnd_l2rw_qc, & pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cao_check + use qcmod, only: troflg,lat_c,nrand 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 + clip_supersaturation,cnvw_option use state_vectors, only: init_anasv,final_anasv use control_vectors, only: init_anacv,final_anacv,nrf,nvars,nrf_3d,cvars3d,cvars2d,& - nrf_var,lcalc_gfdl_cfrac + nrf_var,lcalc_gfdl_cfrac,incvars_to_zero,incvars_zero_strat,incvars_efold 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 @@ -120,7 +121,7 @@ module gsimod 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_gfs_ncio,write_fv3_incr,& 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,print_obs_para @@ -426,7 +427,13 @@ module gsimod ! 08-23-2019 pondeca add logical variable "use_similarity_2dvar" that provides option to use ! similarity theory from the mm5 sfc model to compute the 10-m wind factor for ! near-surface observations +! 09-04-2019 Martin Add option write_fv3_incr to write netCDF increment rather than NEMSIO analysis +! 09-13-2019 Martin Add option incvars_to_zero(nvars) to zero out netCDF increment fields +! 09-20-2019 Su add new variational QC and hub norm option +! 09-23-2019 Martin Add option use_gfs_ncio to read in first-guess netCDF file ! 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 +! 10-28-2019 Martin Add option incvars_zero_strat(nvars) to zero out increments above tropopause ! 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 @@ -561,6 +568,7 @@ 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_gfs_ncio - option to use netCDF to read global model FV3-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 @@ -619,6 +627,15 @@ module gsimod ! 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 +! write_fv3_incr - trigger writing out FV3 netCDF increment file +! rather than NEMSIO analysis +! incvars_to_zero - list of strings of variable names in FV3 netCDF +! increment file that should be forced to be zero +! incvars_zero_strat - list of strings of variable names in FV3 netcdf +! increment file that will be reduced to zero +! above the tropopause +! incvars_efold - scale factor x in which e^(-(k-ktrop)/x) for above fields +! ! 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 @@ -657,7 +674,7 @@ module gsimod 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,& + lwrite_peakwt,use_gfs_nemsio,use_gfs_ncio,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,id_ship,verbose,print_obs_para,lsingleradar,singleradar,lnobalance, & @@ -668,7 +685,8 @@ module gsimod 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,diag_version,& - cao_check,lcalc_gfdl_cfrac,tau_fcst,efsoi_order,lupdqc,lqcoef + write_fv3_incr,incvars_to_zero,incvars_zero_strat,incvars_efold,diag_version,& + cao_check,lcalc_gfdl_cfrac,tau_fcst,efsoi_order,lupdqc,lqcoef,cnvw_option ! GRIDOPTS (grid setup variables,including regional specific variables): ! jcap - spectral resolution @@ -863,6 +881,9 @@ 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 +! nvqc - when true, use Dr. Purser's variational QC +! hub_norm - when true,use huber norm format distribution +! closest_obs- when true, choose the timely closest surface observation from ! multiple observations at a station. Currently only applied to Ceiling ! height and visibility. ! pvis - power parameter in nonlinear transformation for vis @@ -920,7 +941,7 @@ module gsimod 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,& + tcp_ermin,tcp_ermax,qc_noirjaco3,qc_noirjaco3_pole,qc_satwnds,njqc,vqc,nvqc,hub_norm,troflg,lat_c,nrand,& aircraft_t_bc_pof,aircraft_t_bc,aircraft_t_bc_ext,biaspredt,upd_aircraft,cleanup_tail,& hdist_aircraft,buddycheck_t,buddydiag_save,vadwnd_l2rw_qc, & pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cld_det_dec2bin, & @@ -1403,8 +1424,9 @@ subroutine gsimain_initialize end if end if if(ltlint) then - if(vqc .or. njqc)then + if(vqc .or. njqc .or. nvqc)then vqc = .false. + nvqc = .false. njqc = .false. if(mype == 0) write(6,*) ' ltlint = true, so vqc and njqc must be false' end if diff --git a/src/gsi/guess_grids.F90 b/src/gsi/guess_grids.F90 index 76e68f3a34..9eee5253fa 100644 --- a/src/gsi/guess_grids.F90 +++ b/src/gsi/guess_grids.F90 @@ -102,6 +102,7 @@ module guess_grids ! 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 +! 2019-09-10 martin - added new fields to save guess tsen/geop_hgt for writing increment ! ! !AUTHOR: ! kleist org: np20 date: 2003-12-01 @@ -143,6 +144,7 @@ module guess_grids public :: wgt_lcbas public :: ges_qsat public :: use_compress,nsig_ext,gpstop + public :: ges_tsen1,ges_q1 public :: ntguesaer,ifileaer,nfldaer,hrdifaer ! variables for external aerosol files public :: ges_initialized @@ -257,6 +259,8 @@ module guess_grids real(r_kind),allocatable,dimension(:,:,:,:):: ges_lnprsl! log(layer midpoint pressure) real(r_kind),allocatable,dimension(:,:,:,:):: ges_lnprsi! log(interface pressure) real(r_kind),allocatable,dimension(:,:,:,:):: ges_tsen ! sensible temperature + real(r_kind),allocatable,dimension(:,:,:,:):: ges_tsen1 ! to save the first guess for increment + real(r_kind),allocatable,dimension(:,:,:,:):: ges_q1 ! to save the first guess q for increment real(r_kind),allocatable,dimension(:,:,:,:):: ges_teta ! potential temperature real(r_kind),allocatable,dimension(:,:,:):: fact_tv ! 1./(one+fv*ges_q) for virt to sen calc. @@ -440,6 +444,7 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) ! 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 +! 2019-09-10 martin - added new fields to save guess tsen/geop_hgt for writing increment ! ! !REMARKS: ! language: f90 @@ -473,6 +478,8 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) allocate ( ges_prsi(lat2,lon2,nsig+1,nfldsig),ges_prsl(lat2,lon2,nsig,nfldsig),& ges_lnprsl(lat2,lon2,nsig,nfldsig),ges_lnprsi(lat2,lon2,nsig+1,nfldsig),& ges_tsen(lat2,lon2,nsig,nfldsig),& + ges_tsen1(lat2,lon2,nsig,nfldsig),& + ges_q1(lat2,lon2,nsig,nfldsig),& ges_teta(lat2,lon2,nsig,nfldsig),& ges_rho(lat2,lon2,nsig,nfldsig), & geop_hgtl(lat2,lon2,nsig,nfldsig), & @@ -527,6 +534,8 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) ges_rho(i,j,k,n)=zero ges_qsat(i,j,k,n)=zero ges_tsen(i,j,k,n)=zero + ges_tsen1(i,j,k,n)=zero + ges_q1(i,j,k,n)=zero ges_teta(i,j,k,n)=zero geop_hgtl(i,j,k,n)=zero end do @@ -813,6 +822,7 @@ subroutine destroy_ges_grids ! 2006-12-15 todling - using internal switches to deallc(tnds/drvs) ! 2007-03-15 todling - merged in da Silva/Cruz ESMF changes ! 2012-05-14 todling - revist cw check to check also on some hyrometeors +! 2019-09-10 martin - added new fields to save guess tsen/geop_hgt for writing increment ! ! !REMARKS: ! language: f90 @@ -831,6 +841,7 @@ subroutine destroy_ges_grids ! deallocate(ges_prsi,ges_prsl,ges_lnprsl,ges_lnprsi,& ges_tsen,ges_teta,geop_hgtl,geop_hgti,ges_geopi,ges_prslavg,ges_rho,& + ges_tsen1,ges_q1,& tropprs,fact_tv,pbl_height,wgt_lcbas,ges_qsat,stat=istatus) if(w_exist) deallocate(ges_w_btlev,stat=istatus) if (istatus/=0) & diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 4e50bd9744..9231392f6b 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -1176,7 +1176,7 @@ subroutine load_ensemble 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 + use mpimod, only: mpi_comm_world implicit none diff --git a/src/gsi/intps.f90 b/src/gsi/intps.f90 index 0da0e1191a..9ac8b90eaa 100644 --- a/src/gsi/intps.f90 +++ b/src/gsi/intps.f90 @@ -76,7 +76,7 @@ subroutine intps_(pshead,rval,sval) ! 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 ! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. - +! 2019-09-20 Su - remove current VQC part and add VQC subroutine call ! ! input argument list: ! pshead - obs type pointer to obs structure @@ -92,9 +92,9 @@ subroutine intps_(pshead,rval,sval) ! !$$$ use kinds, only: r_kind,i_kind - use constants, only: half,one,tiny_r_kind,cg_term,r3600,two + use constants, only: half,one,tiny_r_kind,cg_term,r3600,two,zero use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag - use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc + use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc,nvqc use jfunc, only: jiter use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -108,9 +108,9 @@ subroutine intps_(pshead,rval,sval) ! Declare local variables integer(i_kind) ier,istatus - integer(i_kind) j1,j2,j3,j4 + integer(i_kind) j1,j2,j3,j4,ibb,ikk ! real(r_kind) penalty - real(r_kind) cg_ps,val,p0,grad,wnotgross,wgross,ps_pg + real(r_kind) cg_t,val,grad,t_pg,var_jb,error2,rat_error2 real(r_kind) w1,w2,w3,w4 real(r_kind),pointer,dimension(:) :: sp real(r_kind),pointer,dimension(:) :: rp @@ -156,21 +156,31 @@ subroutine intps_(pshead,rval,sval) if (.not. lsaveobsens) then if( .not. ladtest_obs) val=val-psptr%res ! gradient of nonlinear operator + rat_error2=psptr%raterr2 + error2=psptr%err2 + if (vqc .and. nlnqc_iter .and. psptr%pg > tiny_r_kind .and. & psptr%b > tiny_r_kind) then - ps_pg=psptr%pg*varqc_iter - cg_ps=cg_term/psptr%b ! b is d in Enderson - wnotgross= one-ps_pg ! pg is A in Enderson - wgross =ps_pg*cg_ps/wnotgross ! wgross is gama in Enderson - p0=wgross/(wgross+exp(-half*psptr%err2*val**2)) ! p0 is P in Enderson - val=val*(one-p0) ! term is Wqc in Enderson + t_pg=psptr%pg*varqc_iter + cg_t=cg_term/psptr%b ! b is d in Enderson + else + t_pg=zero + cg_t=zero endif if (njqc .and. psptr%jb > tiny_r_kind .and. psptr%jb <10.0_r_kind) then - val=sqrt(two*psptr%jb)*tanh(sqrt(psptr%err2)*val/sqrt(two*psptr%jb)) - grad = val*psptr%raterr2*sqrt(psptr%err2) + var_jb=psptr%jb else - grad = val*psptr%raterr2*psptr%err2 + var_jb=zero endif + if(nvqc .and. psptr%ib >0) then + ibb=psptr%ib + ikk=psptr%ik + else + ibb=0 + ikk=0 + endif + call vqc_int(error2,rat_error2,t_pg,cg_t,var_jb,ibb,ikk,val,grad) + if( ladtest_obs) then grad = val endif diff --git a/src/gsi/intq.f90 b/src/gsi/intq.f90 index ef7cba5f3f..ce5f473fe3 100644 --- a/src/gsi/intq.f90 +++ b/src/gsi/intq.f90 @@ -76,6 +76,7 @@ subroutine intq_(qhead,rval,sval) ! 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 ! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. +! 2019-09-20 Su - remove current VQC part and add VQC subroutine call ! ! input argument list: ! qhead - obs type pointer to obs structure @@ -91,9 +92,9 @@ subroutine intq_(qhead,rval,sval) ! !$$$ use kinds, only: r_kind,i_kind - use constants, only: half,one,tiny_r_kind,cg_term,r3600,two + use constants, only: half,one,tiny_r_kind,cg_term,r3600,two,zero use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag - use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc + use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc,nvqc use jfunc, only: jiter use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -107,9 +108,9 @@ subroutine intq_(qhead,rval,sval) ! Declare local variables integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus - real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8 + real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8,ibb,ikk ! real(r_kind) penalty - real(r_kind) cg_q,val,p0,grad,wnotgross,wgross,q_pg + real(r_kind) cg_t,val,grad,t_pg,var_jb,error2,rat_error2 real(r_kind),pointer,dimension(:) :: sq real(r_kind),pointer,dimension(:) :: rq type(qNode), pointer :: qptr @@ -163,23 +164,32 @@ subroutine intq_(qhead,rval,sval) if( .not. ladtest_obs) val=val-qptr%res ! gradient of nonlinear operator - + rat_error2=qptr%raterr2 + error2=qptr%err2 + if (vqc .and. nlnqc_iter .and. qptr%pg > tiny_r_kind .and. & qptr%b > tiny_r_kind) then - q_pg=qptr%pg*varqc_iter - cg_q=cg_term/qptr%b - wnotgross= one-q_pg - wgross =q_pg*cg_q/wnotgross ! wgross is gama in the reference by Enderson - p0=wgross/(wgross+exp(-half*qptr%err2*val**2)) ! p0 is P in the reference by Enderson - val=val*(one-p0) ! term is Wqc in the referenc by Enderson + t_pg=qptr%pg*varqc_iter + cg_t=cg_term/qptr%b ! b is d in Enderson + else + t_pg=zero + cg_t=zero endif - - if (njqc .and. qptr%jb > tiny_r_kind .and. qptr%jb <10.0_r_kind) then - val=sqrt(two*qptr%jb)*tanh(sqrt(qptr%err2)*val/sqrt(two*qptr%jb)) - grad = val*qptr%raterr2*sqrt(qptr%err2) + if (njqc .and. qptr%jb > tiny_r_kind .and. qptr%jb <10.0_r_kind) then + var_jb=qptr%jb else - grad = val*qptr%raterr2*qptr%err2 + var_jb=zero endif + if(nvqc .and. qptr%ib >0) then + ibb=qptr%ib + ikk=qptr%ik + else + ibb=0 + ikk=0 + endif + + call vqc_int(error2,rat_error2,t_pg,cg_t,var_jb,ibb,ikk,val,grad) + if( ladtest_obs) then grad = val end if diff --git a/src/gsi/intt.f90 b/src/gsi/intt.f90 index f5ba3ebdde..9401026e47 100644 --- a/src/gsi/intt.f90 +++ b/src/gsi/intt.f90 @@ -83,6 +83,7 @@ subroutine intt_(thead,rval,sval,rpred,spred) ! 2013-05-26 zhu - add aircraft temperature bias correction contribution ! 2014-12-03 derber - modify so that use of obsdiags can be turned off ! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. +! 2019-09-20 Su - remove current VQC part and add VQC subroutine call ! ! input argument list: ! thead - obs type pointer to obs structure @@ -118,7 +119,7 @@ subroutine intt_(thead,rval,sval,rpred,spred) use kinds, only: r_kind,i_kind,r_quad use constants, only: half,one,zero,tiny_r_kind,cg_term,r3600,two use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag - use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc + use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc,nvqc use jfunc, only: jiter use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -146,11 +147,12 @@ subroutine intt_(thead,rval,sval,rpred,spred) integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus,isst,ix,n real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8,time_t ! real(r_kind) penalty - real(r_kind) cg_t,val,p0,grad,wnotgross,wgross,t_pg + real(r_kind) cg_t,val,grad,rat_err2,error2,t_pg,var_jb real(r_kind) psfc_grad,tg_grad real(r_kind) ts_grad,us_grad,vs_grad,qs_grad real(r_kind) qs_prime0,tg_prime0,ts_prime0,psfc_prime0 real(r_kind) us_prime0,vs_prime0 + integer(i_kind) ibb,ikk type(tNode), pointer :: tptr ! If no t data return @@ -260,22 +262,31 @@ subroutine intt_(thead,rval,sval,rpred,spred) if( .not. ladtest_obs) val=val-tptr%res ! gradient of nonlinear operator - + error2=tptr%err2 + rat_err2=tptr%raterr2 if (vqc .and. nlnqc_iter .and. tptr%pg > tiny_r_kind .and. & tptr%b > tiny_r_kind) then t_pg=tptr%pg*varqc_iter cg_t=cg_term/tptr%b - wnotgross= one-t_pg - wgross =t_pg*cg_t/wnotgross - p0=wgross/(wgross+exp(-half*tptr%err2*val**2)) - val=val*(one-p0) + else + t_pg=zero + cg_t=zero endif if (njqc .and. tptr%jb > tiny_r_kind .and. tptr%jb <10.0_r_kind) then - val=sqrt(two*tptr%jb)*tanh(sqrt(tptr%err2)*val/sqrt(two*tptr%jb)) - grad = val*tptr%raterr2*sqrt(tptr%err2) + var_jb=tptr%jb + else + var_jb=zero + endif + if (nvqc .and. tptr%ib > tiny_r_kind ) then + ibb=tptr%ib + ikk=tptr%ik else - grad = val*tptr%raterr2*tptr%err2 + ibb=0 + ikk=0 endif + + call vqc_int(error2,rat_err2,t_pg,cg_t,var_jb,ibb,ikk,val,grad) + if(ladtest_obs) then grad = val endif diff --git a/src/gsi/intw.f90 b/src/gsi/intw.f90 index d1013d60a2..06d13cec2e 100644 --- a/src/gsi/intw.f90 +++ b/src/gsi/intw.f90 @@ -75,6 +75,7 @@ subroutine intw_(whead,rval,sval) ! 2014-04-12 su - add non linear qc from Purser's scheme ! 2014-12-03 derber - modify so that use of obsdiags can be turned off ! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. +! 2019-09-20 Su - add new variational scheme ! ! input argument list: ! whead - obs type pointer to obs structure @@ -95,11 +96,12 @@ subroutine intw_(whead,rval,sval) use kinds, only: r_kind,i_kind use constants, only: half,one,tiny_r_kind,cg_term,r3600,two use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag - use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc + use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc,nvqc,hub_norm use jfunc, only: jiter use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_4dvar, only: ladtest_obs + use pvqc, only: vqch,vqcs implicit none ! Declare passed variables @@ -109,8 +111,10 @@ subroutine intw_(whead,rval,sval) ! Declare local variables integer(i_kind) i1,i2,i3,i4,i5,i6,i7,i8,ier,istatus + integer(i_kind) ib,ik ! real(r_kind) penalty real(r_kind) valu,valv,w1,w2,w3,w4,w5,w6,w7,w8 + real(r_kind) gu,gv,wu,wv,ww real(r_kind) cg_w,p0,gradu,gradv,wnotgross,wgross,term,w_pg real(r_kind),pointer,dimension(:) :: su,sv real(r_kind),pointer,dimension(:) :: ru,rv @@ -178,6 +182,7 @@ subroutine intw_(whead,rval,sval) end if ! gradient of nonlinear operator + if (vqc .and. nlnqc_iter .and. wptr%pg > tiny_r_kind .and. & wptr%b > tiny_r_kind) then @@ -190,16 +195,36 @@ subroutine intw_(whead,rval,sval) term=one-p0 ! term is Wqc in Enderson valu = valu*term valv = valv*term - endif - if (njqc .and. wptr%jb > tiny_r_kind .and. wptr%jb <10.0_r_kind) then + gradu = valu*wptr%raterr2*wptr%err2 + gradv = valv*wptr%raterr2*wptr%err2 + else if (njqc .and. wptr%jb > tiny_r_kind .and. wptr%jb <10.0_r_kind) then valu=sqrt(two*wptr%jb)*tanh(sqrt(wptr%err2)*valu/sqrt(two*wptr%jb)) valv=sqrt(two*wptr%jb)*tanh(sqrt(wptr%err2)*valv/sqrt(two*wptr%jb)) gradu = valu*wptr%raterr2*sqrt(wptr%err2) gradv = valv*wptr%raterr2*sqrt(wptr%err2) + else if (nvqc .and. wptr%ib >0) then + ib=wptr%ib + ik=wptr%ik + ww=valu*sqrt(wptr%err2) + if(hub_norm) then + call vqch(ib,ik,ww,gu,wu) + else + call vqcs(ib,ik,ww,gu,wu) + endif + gradu =wu*ww*sqrt(wptr%err2)*wptr%raterr2 + ww=valv*sqrt(wptr%err2) + if(hub_norm) then + call vqch(ib,ik,ww,gv,wv) + else + call vqcs(ib,ik,ww,gv,wv) + endif + gradv =wv*ww*sqrt(wptr%err2)*wptr%raterr2 else gradu = valu*wptr%raterr2*wptr%err2 gradv = valv*wptr%raterr2*wptr%err2 endif + + if( ladtest_obs) then gradu = valu gradv = valv diff --git a/src/gsi/jfunc.f90 b/src/gsi/jfunc.f90 index 428ad41ec1..94a2272851 100644 --- a/src/gsi/jfunc.f90 +++ b/src/gsi/jfunc.f90 @@ -137,10 +137,12 @@ module jfunc public :: factg,factv,factp,factl,R_option,factw10m,facthowv,factcldch,diag_precon,step_start public :: pseudo_q2 public :: varq + public :: cnvw_option logical first,last,switch_on_derivatives,tendsflag,print_diag_pcg,tsensible,lgschmidt,diag_precon logical clip_supersaturation,R_option logical pseudo_q2 + logical cnvw_option integer(i_kind) iout_iter,miter,iguess,nclen,qoption,cwoption integer(i_kind) jiter,jiterstart,jiterend,iter integer(i_kind) nvals_len,nvals_levs @@ -245,6 +247,9 @@ subroutine init_jfunc iguess=1 +! option for including convective clouds in the all-sky assimilation + cnvw_option=.false. + return end subroutine init_jfunc diff --git a/src/gsi/kinds.F90 b/src/gsi/kinds.F90 index 8b3a2fcc4e..a3f0f397ec 100644 --- a/src/gsi/kinds.F90 +++ b/src/gsi/kinds.F90 @@ -106,7 +106,13 @@ module kinds integer, parameter, private :: default_real = 3 ! 3=quad #endif integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: dp = real_kinds( default_real ) + integer, parameter, public :: sp = r_single integer, parameter, public :: num_bytes_for_r_kind = & real_byte_sizes( default_real ) + integer,parameter, public :: spc=kind((1.0,1.0)) + integer,parameter, public :: dpc=kind((1.0d0,1.0d0)) + private:: one_dpi; integer(8),parameter:: one_dpi=1 + integer,parameter , public :: dpi=kind(one_dpi) end module kinds diff --git a/src/gsi/m_psNode.F90 b/src/gsi/m_psNode.F90 index 2ee19558c5..988edee011 100644 --- a/src/gsi/m_psNode.F90 +++ b/src/gsi/m_psNode.F90 @@ -11,6 +11,7 @@ module m_psNode ! program history log: ! 2016-05-18 j guo - added this document block for the initial polymorphic ! implementation. +! 2019-09-20 X.Su - add new variational QC parameters ! ! input argument list: see Fortran 90 style document below ! @@ -43,6 +44,8 @@ module m_psNode 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) :: jb =0._r_kind ! variational quality control parameter + integer(i_kind) :: ib =0_i_kind ! new variational quality control parameter + integer(i_kind) :: ik =0_i_kind ! new variational quality control parameter real(r_kind) :: wij(4) =0._r_kind ! horizontal interpolation weights real(r_kind) :: ppertb =0._r_kind ! random number adding to the obs integer(i_kind) :: ij(4) =0_i_kind ! horizontal locations @@ -164,6 +167,8 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%ppertb , & aNode%kx , & aNode%wij , & @@ -200,6 +205,8 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%ppertb , & aNode%kx , & aNode%wij , & diff --git a/src/gsi/m_qNode.F90 b/src/gsi/m_qNode.F90 index e71c41885a..b6b24d09f1 100644 --- a/src/gsi/m_qNode.F90 +++ b/src/gsi/m_qNode.F90 @@ -11,6 +11,7 @@ module m_qNode ! program history log: ! 2016-05-18 j guo - added this document block for the initial polymorphic ! implementation. +! 2019-09-20 X.Su - add new variational QC parameters ! ! input argument list: see Fortran 90 style document below ! @@ -44,6 +45,8 @@ module m_qNode real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: jb ! variational quality control parameter + integer(i_kind) :: ib ! new variational quality control parameter + integer(i_kind) :: ik ! new variational quality control parameter real(r_kind) :: wij(8) ! horizontal interpolation weights real(r_kind) :: qpertb ! random number adding to the obs integer(i_kind) :: ij(8) ! horizontal locations @@ -178,6 +181,8 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%qpertb , & aNode%k1 , & aNode%kx , & @@ -219,6 +224,8 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%qpertb , & aNode%k1 , & aNode%kx , & diff --git a/src/gsi/m_tNode.F90 b/src/gsi/m_tNode.F90 index 902e254dbf..8ddb9fb1ed 100644 --- a/src/gsi/m_tNode.F90 +++ b/src/gsi/m_tNode.F90 @@ -11,6 +11,7 @@ module m_tNode ! program history log: ! 2016-05-18 j guo - added this document block for the initial polymorphic ! implementation. +! 2019-09-20 X.Su - add new variational QC parameters ! ! input argument list: see Fortran 90 style document below ! @@ -44,6 +45,8 @@ module m_tNode real(r_kind) :: b ! variational quality control parameter real(r_kind) :: pg ! variational quality control parameter real(r_kind) :: jb ! variational quality control parameter + integer(i_kind) :: ib ! new variational quality control parameter + integer(i_kind) :: ik ! new variational quality control parameter real(r_kind) :: tlm_tsfc(6) ! sensitivity vector for sfc temp ! forward model real(r_kind) :: wij(8) ! horizontal interpolation weights @@ -221,6 +224,8 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%use_sfc_model, & aNode%tlm_tsfc , & aNode%tpertb , & @@ -245,6 +250,8 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%use_sfc_model, & aNode%tlm_tsfc , & aNode%tpertb , & @@ -296,6 +303,8 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%use_sfc_model, & aNode%tlm_tsfc , & aNode%tpertb , & @@ -320,6 +329,8 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%use_sfc_model, & aNode%tlm_tsfc , & aNode%tpertb , & diff --git a/src/gsi/m_wNode.F90 b/src/gsi/m_wNode.F90 index 43190b75ca..2cfdf67b44 100644 --- a/src/gsi/m_wNode.F90 +++ b/src/gsi/m_wNode.F90 @@ -11,6 +11,7 @@ module m_wNode ! program history log: ! 2016-05-18 j guo - added this document block for the initial polymorphic ! implementation. +! 2019-09-20 X.Su - add new variational QC parameters ! ! input argument list: see Fortran 90 style document below ! @@ -41,11 +42,12 @@ module m_wNode real(r_kind) :: vres ! v component residual real(r_kind) :: err2 ! surface pressure 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) :: jb ! variational quality control parameter + integer(i_kind) :: ib ! new variational quality control parameter + integer(i_kind) :: ik ! new variational quality control parameter real(r_kind) :: wij(8) ! horizontal interpolation weights real(r_kind) :: upertb ! random number adding to the obs real(r_kind) :: vpertb ! random number adding to the obs @@ -181,6 +183,8 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%upertb , & aNode%vpertb , & aNode%k1 , & @@ -232,6 +236,8 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%b , & aNode%pg , & aNode%jb , & + aNode%ib , & + aNode%ik , & aNode%upertb , & aNode%vpertb , & aNode%k1 , & diff --git a/src/gsi/ncepgfs_io.f90 b/src/gsi/ncepgfs_io.f90 index 2a7ad4aa36..52dcc4e1b5 100644 --- a/src/gsi/ncepgfs_io.f90 +++ b/src/gsi/ncepgfs_io.f90 @@ -1135,6 +1135,9 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) ! 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 +! 2019-09-04 martin - added option to write fv3 netcdf increment file +! 2019-09-24 martin - added logic for when use_gfs_ncio is true, note +! writing netCDF analysis for GFS not currently supported ! ! input argument list: ! increment - when >0 will write increment from increment-index slot @@ -1152,7 +1155,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) use mpimod, only: mype use guess_grids, only: dsfct use guess_grids, only: ntguessig,ntguessfc,ifilesig,nfldsig - use gridmod, only: hires_b,sp_a,grd_a,jcap_b,nlon,nlat,use_gfs_nemsio + use gridmod, only: hires_b,sp_a,grd_a,jcap_b,nlon,nlat,use_gfs_nemsio,write_fv3_incr,use_gfs_ncio use gsi_metguess_mod, only: gsi_metguess_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: gsi_grid @@ -1167,6 +1170,8 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) use general_specmod, only: general_init_spec_vars,general_destroy_spec_vars,spec_vars use gsi_4dvar, only: lwrite4danl,nhr_anal use ncepnems_io, only: write_nemsatm,write_nemssfc,write_nems_sfc_nst + use netcdfgfs_io, only: write_gfsncsfc, write_gfsnc_sfc_nst, write_gfsncatm + use write_incr, only: write_fv3_increment use ncepnems_io, only: write_fv3atm_nems use gridmod, only: fv3_full_hydro use gsi_chemguess_mod, only: gsi_chemguess_get,gsi_chemguess_bundle @@ -1341,13 +1346,13 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) endif itoutsig = it if ( it == ntguessig ) then - if ( increment > 0 ) then + if ( increment > 0 .or. write_fv3_incr ) then filename = 'siginc' else filename = 'siganl' endif else - if ( increment > 0 ) then + if ( increment > 0 .or. write_fv3_incr ) then write(filename,"('sigi',i2.2)") ifilesig(it) else write(filename,"('siga',i2.2)") ifilesig(it) @@ -1355,7 +1360,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) endif else itoutsig = ntguessig - if ( increment > 0 ) then + if ( increment > 0 .or. write_fv3_incr ) then filename = 'siginc' else filename = 'siganl' @@ -1363,7 +1368,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) endif if ( mype == 0 ) then - if ( increment > 0 ) then + if ( increment > 0 .or. write_fv3_incr ) then write(6,'(A,I2.2)') 'WRITE_GFS: writing analysis increment for FHR ', ifilesig(itoutsig) else write(6,'(A,I2.2)') 'WRITE_GFS: writing full analysis state for FHR ', ifilesig(itoutsig) @@ -1434,21 +1439,34 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) end if ! laeroana_gocart if ( use_gfs_nemsio ) then - 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 - + if ( write_fv3_incr ) then + call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + else + 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 + end if + + else if ( use_gfs_ncio ) then + if ( write_fv3_incr ) then + call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + else + call write_gfsncatm(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + end if else ! If hires_b, spectral to grid transform for background @@ -1482,6 +1500,8 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) filename='sfcinc.gsi' if ( use_gfs_nemsio ) then call write_nemssfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) + else if ( use_gfs_ncio ) then + call write_gfsncsfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) else call write_gfssfc(filename,mype_sfc,dsfct(1,1,ntguessfc)) endif @@ -1492,6 +1512,8 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) else if ( use_gfs_nemsio ) then call write_nems_sfc_nst(mype_sfc,dsfct(:,:,ntguessfc)) + else if ( use_gfs_ncio ) then + call write_gfsnc_sfc_nst(mype_sfc,dsfct(:,:,ntguessfc)) else call write_gfs_sfc_nst (mype_sfc,dsfct(1,1,ntguessfc)) endif @@ -1500,6 +1522,8 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) filename='sfcanl.gsi' if ( use_gfs_nemsio ) then call write_nemssfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) + else if ( use_gfs_ncio ) then + call write_gfsncsfc(filename,mype_sfc,dsfct(:,:,ntguessfc)) else call write_gfssfc (filename,mype_sfc,dsfct(1,1,ntguessfc)) endif diff --git a/src/gsi/ncepnems_io.f90 b/src/gsi/ncepnems_io.f90 index 7727cce33d..0525b83bf9 100755 --- a/src/gsi/ncepnems_io.f90 +++ b/src/gsi/ncepnems_io.f90 @@ -242,6 +242,7 @@ subroutine read_ ! ticket #239, comment 18) ! 2018-05-19 eliu - add components to read in hydrometeor related ! variables +! 2019-07-10 Zhu - Add convective clouds ! ! input argument list: ! @@ -348,7 +349,7 @@ subroutine read_ atm_bundle,.true.,istatus) else call general_read_gfsatm_nems(grd_t,sp_a,filename,.true.,.true.,.true.,& - atm_bundle,.true.,istatus) + atm_bundle,.true.,istatus,it) endif inithead=.false. @@ -531,7 +532,6 @@ subroutine read_chem_ ( iyear, month,idd ) 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 @@ -2084,7 +2084,6 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) 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 @@ -2141,10 +2140,10 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) 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%lat2,grd%lon2,grd%nsig):: sub_dp 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):: dpsm, 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 @@ -2327,6 +2326,7 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) call strip(sub_tv ,tvsm ,grd%nsig) call strip(sub_q ,qsm ,grd%nsig) call strip(sub_oz ,ozsm ,grd%nsig) + call strip(sub_dp ,dpsm ,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) @@ -2800,9 +2800,10 @@ subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) work1,grd%ijn,grd%displs_g,mpi_rtype,& mype_out,mpi_comm_world,ierror) if (mype == mype_out) then + work1 = -one * work1 ! Flip sign, FV3 is top to bottom 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 (sum(rwork1d) < zero) work1 = -one * work1 !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 @@ -2895,7 +2896,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle use mpimod, only: mype use guess_grids, only: ifilesig - use guess_grids, only: ges_prsl,ges_prsi + use guess_grids, only: ges_prsi use guess_grids, only: load_geop_hgt,geop_hgti,ges_geopi use gridmod, only: ntracer @@ -2957,10 +2958,12 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle 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%lat2,grd%lon2,grd%nsig+1) :: sub_prsi 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, usm, vsm - real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: qsm, ozsm + 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 ! Aerosol array real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: & @@ -3137,6 +3140,12 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','write',istop,iret) endif ! if ( mype == mype_out ) + 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 do k=1,grd%nsig @@ -3157,6 +3166,7 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle 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_u ,usm ,grd%nsig) call strip(sub_v ,vsm ,grd%nsig) if (lupp) call strip(sub_dza ,dzsm ,grd%nsig) @@ -3521,9 +3531,10 @@ subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle work1,grd%ijn,grd%displs_g,mpi_rtype,& mype_out,mpi_comm_world,ierror) if (mype == mype_out) then + work1 = -one * work1 ! Flip sign, FV3 is top to bottom 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 (sum(rwork1d) < zero) work1 = -one * work1 ! 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 diff --git a/src/gsi/netcdfgfs_io.f90 b/src/gsi/netcdfgfs_io.f90 new file mode 100644 index 0000000000..eb90b7d142 --- /dev/null +++ b/src/gsi/netcdfgfs_io.f90 @@ -0,0 +1,3112 @@ +module netcdfgfs_io +!$$$ module documentation block +! . . . . +! module: netcdfgfs_io +! prgmmr: Martin org: NCEP/EMC date: 2019-09-24 +! +! abstract: This module contains routines which handle input/output +! operations for NCEP FV3 GFS netCDF global atmospheric and surface files. +! +! program history log: +! 2019-09-24 Martin Initial version. Based on ncepnems_io +! +! Subroutines Included: +! sub read_gfsnc - driver to read fv3gfs netcdf atmospheric and surface +! sub read_gfsnc_chem +! sub read_gfsncatm - read fv3gfs netcdf atmospheric file, scatter +! on grid to analysis subdomains +! sub read_gfsncsfc - read fv3gfs netcdf surface file, scatter on grid to +! analysis subdomains +! sub read_gfsncsfc_anl- read ncep EnKF fv3gfs netcdf surface file, scatter on grid to +! analysis subdomains +! sub write_gfsncsfc - gather/write on grid ncep surface analysis file +! sub read_gfsncnst - read ncep nst file, scatter on grid to analysis subdomains +! sub write_gfsnc_sfc_nst - gather/write on grid ncep surface & nst analysis file +! sub intrp22 - interpolate from one grid to another grid (2D) +! sub read_gfsnc_sfcnst - read sfc hist file, including sfc and nst vars, scatter on grid to analysis subdomains +! +! Variable Definitions: +! +! language: f90 +! machine: +! +! NOTE: This module adds capability to read netCDF FV3 first guess files +! and to write netCDF FV3 analysis files using the fv3gfs_ncio interface +! Using this is controled by a namelist argument "use_gfs_ncio" +! +! +!$$$ end documentation block + + use constants, only: zero,one,fv,r60,r3600 + implicit none + + private + public read_gfsnc + public read_gfsnc_chem + public read_gfsncatm + public read_gfsncsfc + public read_gfsncsfc_anl + public write_gfsncsfc + public read_gfsncnst + public write_gfsnc_sfc_nst + public intrp22 + public tran_gfsncsfc + public write_gfsncatm + + interface read_gfsnc + module procedure read_ + end interface + + interface read_gfsnc_chem + module procedure read_chem_ + end interface + + interface read_gfsncatm + module procedure read_atm_ + end interface + + interface read_gfsncsfc + module procedure read_gfsncsfc_ + end interface + + interface read_gfsncsfc_anl + module procedure read_gfsncsfc_anl_ + end interface + + interface read_gfsncnst + module procedure read_gfsncnst_ + end interface + + + interface write_gfsncsfc + module procedure write_sfc_ + end interface + + interface write_gfsnc_sfc_nst + module procedure write_sfc_nst_ + end interface + + interface write_gfsncatm + module procedure write_atm_ + end interface + + character(len=*),parameter::myname='netcdfgfs_io' + +contains + + subroutine read_ +!$$$ subprogram documentation block +! . . . +! subprogram: read_gfsnc +! +! prgrmmr: Martin +! +! abstract: +! +! program history log: +! 2019-09-24 Martin - create routine based on read_nems +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! +!$$$ 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_nc(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_NETCDF: 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_ NETCDF: cannot get pointer to ql,iret_ql=',iret_ql + endif + if (iret_qi/=0) then + if (mype==0) write(6,*)'READ_ NETCDF: 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_gfsnc_chem +! +! prgrmmr: martin +! +! 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: +! 2019-09-24 martin - initial code, based on read_nems_chem +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! +!$$$ 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_gfsncatm read GFS netCDF atm and send to all mpi tasks +! prgmmr: Martin org: NCEP/EMC date: 2019-09-23 +! +! abstract: read ncep netcdf/gfs atmospheric guess field and +! scatter to subdomains +! +! program history log: +! 2019-09-23 Martin Initial version. Based on sub read_nemsatm +! +! 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 +! +!$$$ + use kinds, only: r_kind,i_kind, r_single + 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 module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + quantize_data,close_dataset, get_dim, read_vardata, get_idate_from_time_units + 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_GFSNCATM' + integer(i_kind),dimension(6):: idate + integer(i_kind),dimension(4):: odate + integer(i_kind) :: nlatm2,nflds + integer(i_kind) :: k,icount,icount_prev,mm1,i,j,kk,kr + integer(i_kind) :: mype_hs, mype_ps,nord_int + integer(i_kind) :: latb, lonb, levs + 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(:) :: rlats,rlons,clons,slons + real(r_kind),allocatable,dimension(:) :: rlats_tmp,rlons_tmp + real(r_single),allocatable, dimension(:,:) :: rwork2d, rwork2d1 + real(r_single),allocatable, dimension(:,:,:) :: rwork3d, rwork3d1 + real(r_single),allocatable, dimension(:) :: fhour + logical diff_res,eqspace + logical,dimension(1) :: vector + type(egrid2agrid_parm) :: p_high + type(Dataset) :: atmges + type(Dimension) :: ncdim + +!****************************************************************************** +! 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 + + ! open the netCDF file + atmges = open_dataset(filename) + ! get dimension sizes + ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len + ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + + ! get time information + idate = get_idate_from_time_units(atmges) + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later + ! depends on model changes from Jeff Whitaker +! +! 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 + + ! get lat/lon coordinates + + 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( rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb)) + call read_vardata(atmges, 'grid_xt', rlons_tmp) + call read_vardata(atmges, 'grid_yt', rlats_tmp) + do j=1,latb + rlats(j+1)=deg2rad*rlats_tmp(j) + end do + do j=1,lonb + rlons(j)=deg2rad*rlons_tmp(j) + end do + deallocate(rlats_tmp,rlons_tmp) + 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 read_vardata(atmges, 'hgtsfc', rwork2d) + if(diff_res)then + grid_b=rwork2d + 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=rwork2d + 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 read_vardata(atmges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d + if(diff_res)then + vector(1)=.false. + grid_b=rwork2d + 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=rwork2d + 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) ) + call read_vardata(atmges, 'ugrd', rwork3d) + call read_vardata(atmges, 'vgrd', rwork3d1) +! TODO CRM, would above be faster if only done on one PE and then distributed? + do k=1,levs + kr = levs+1-k ! netcdf is top to bottom need to flip + icount=icount+1 + if (mype==mod(icount-1,npe)) then + ! Convert grid u,v to div and vor + if(diff_res)then + grid_b=rwork3d(:,:,kr) + grid_b2=rwork3d1(:,:,kr) + 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=rwork3d(:,:,kr) + grid_v=rwork3d1(:,:,kr) + 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 + call read_vardata(atmges, 'spfh', rwork3d) + call read_vardata(atmges, 'tmp', rwork3d1) + allocate(rwork2d1(lonb,latb)) + do k=1,levs + kr = levs+1-k ! netcdf is top to bottom need to flip + icount=icount+1 + if (mype==mod(icount-1,npe)) then + if(diff_res)then + grid_b=rwork3d(:,:,kr) + 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=rwork3d(:,:,kr) + call fill_ns(grid,work) + end if + + rwork2d1 = rwork3d1(:,:,kr)*(one+fv*rwork3d(:,:,kr)) + if(diff_res)then + grid_b=rwork2d1 + 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=rwork2d1 + call fill_ns(grid_v,work_v) + end if + + 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 + deallocate(rwork2d1) + call reload(sub_v,g_tv) + call reload(sub,g_q) + deallocate(sub_v,work_v) + + sub=zero + icount=0 + icount_prev=1 + call read_vardata(atmges, 'o3mr', rwork3d) ! need k thrown in here somewhere + do k=1,levs + kr = levs+1-k ! netcdf is top to bottom need to flip + icount=icount+1 + if (mype==mod(icount-1,npe)) then + if(diff_res)then + grid_b=rwork3d(:,:,kr) + 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=rwork3d(:,:,kr) + 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 + call read_vardata(atmges, 'clwmr', rwork3d) + call read_vardata(atmges, 'icmr', rwork3d1) + do k=1,levs + kr = levs+1-k ! netcdf is top to bottom need to flip + icount=icount+1 + if (mype==mod(icount-1,npe)) then + rwork2d = rwork3d(:,:,kr) + rwork3d1(:,:,kr) + if(diff_res)then + grid_b=rwork2d + 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=rwork2d + 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(clons,slons) + deallocate(grid,grid_v) + call close_dataset(atmges) + 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 netCDF sfc hist file +! prgmmr: Martin org: NCEP/EMC date: 2019-09-23 +! +! abstract: read nems sfc & nst combined file +! +! program history log: +! 2019-09-23 Martin Initial version. +! +! 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 +! +!$$$ + 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 module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + close_dataset, get_dim, read_vardata, get_idate_from_time_units + 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(6):: 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' + integer(i_kind) :: i,j,it,n,nsfc + integer(i_kind) :: lonb, latb + real(r_single),allocatable, dimension(:) :: fhour + real(r_single), allocatable, dimension(:,:) :: work,outtmp + type(Dataset) :: sfcges + type(Dimension) :: ncdim +!----------------------------------------------------------------------------- + + do it = 1, nfldsfc +! read a surface history file on the task + write(filename,200)ifilesfc(it) +200 format('sfcf',i2.2) + + ! open the netCDF file + sfcges = open_dataset(filename) + ! get dimension sizes + ncdim = get_dim(sfcges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(sfcges, 'grid_yt'); latb = ncdim%len + + ! get time information + idate = get_idate_from_time_units(sfcges) + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + call read_vardata(sfcges, 'time', fhour) ! might need to change this to attribute later + ! depends on model changes from Jeff Whitaker + + 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)) + work = 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 read_vardata(sfcges, 'tmpsfc', work) + call tran_gfsncsfc(work,sfct(1,1,it),lonb,latb) + + elseif(n == 2 .and. use_sfc_any) then ! soil moisture + +! smc/soilw + call read_vardata(sfcges, 'soilw1', work) + call tran_gfsncsfc(work,soil_moi(1,1,it),lonb,latb) + + elseif(n == 3) then ! snow depth + + call read_vardata(sfcges, 'weasd', work) + call tran_gfsncsfc(work,sno(1,1,it),lonb,latb) + + elseif(n == 4 .and. use_sfc_any) then ! soil temperature + +! stc/tmp + call read_vardata(sfcges, 'soilt1', work) + call tran_gfsncsfc(work,soil_temp(1,1,it),lonb,latb) + + elseif(n == 5 .and. use_sfc_any) then ! vegetation cover + +! vfrac + call read_vardata(sfcges, 'veg', work) + call tran_gfsncsfc(work,veg_frac(1,1,it),lonb,latb) + + elseif(n == 6) then ! 10m wind factor + +! f10m + call read_vardata(sfcges, 'f10m', work) + call tran_gfsncsfc(work,fact10(1,1,it),lonb,latb) + + elseif(n == 7) then ! suface roughness + +! zorl + call read_vardata(sfcges, 'sfcr', work) + call tran_gfsncsfc(work,sfc_rough(1,1,it),lonb,latb) + + elseif(n == 8 .and. use_sfc_any) then ! vegetation type + +! vtype + call read_vardata(sfcges, 'vtype', work) + call tran_gfsncsfc(work,veg_type,lonb,latb) + + elseif(n == 9 .and. use_sfc_any) then ! soil type + +! stype + call read_vardata(sfcges, 'sotyp', work) + call tran_gfsncsfc(work,soil_type,lonb,latb) + + elseif(n == 10) then ! terrain + +! orog + call read_vardata(sfcges, 'orog', work) + call tran_gfsncsfc(work,terrain,lonb,latb) + + elseif(n == 11) then ! sea/land/ice flag + +! slmsk + call read_vardata(sfcges, 'land', work) + allocate(outtmp(latb+2,lonb)) + call tran_gfsncsfc(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 read_vardata(sfcges, 'tref', work) + call tran_gfsncsfc(work,tref(1,1,it),lonb,latb) + + call read_vardata(sfcges, 'dtcool', work) + call tran_gfsncsfc(work,dt_cool(1,1,it),lonb,latb) + + call read_vardata(sfcges, 'zc', work) + call tran_gfsncsfc(work,z_c(1,1,it),lonb,latb) + + call read_vardata(sfcges, 'xt', work) + call tran_gfsncsfc(work,xt(1,1,it),lonb,latb) + + call read_vardata(sfcges, 'xz', work) + call tran_gfsncsfc(work,z_w(1,1,it),lonb,latb) + + call read_vardata(sfcges, 'c0', work) + call tran_gfsncsfc(work,c_0(1,1,it),lonb,latb) + + call read_vardata(sfcges, 'cd', work) + call tran_gfsncsfc(work,c_d(1,1,it),lonb,latb) + + call read_vardata(sfcges, 'w0', work) + call tran_gfsncsfc(work,w_0(1,1,it),lonb,latb) + + call read_vardata(sfcges, 'wd', work) + call tran_gfsncsfc(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) + + call close_dataset(sfcges) +! +! 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_gfsncsfc_(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_gfsncsfc_ read netcdf sfc hist file +! prgmmr: martin org: NCEP/EMC date: 2019-09-23 +! +! abstract: read netcdf surface file +! +! program history log: +! 2019-09-23 Martin Initial version. +! +! 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 +! +!$$$ + 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 netcdf, 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 netcdf, 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_gfsncsfc_ + + subroutine read_sfc_anl_(isli_anl) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_sfc_anl_ read netcdf surface file with analysis resolution +! +! prgmmr: martin org: NCEP/EMC date: 2019-09-23 +! +! abstract: read netcdf surface file at analysis grids when nlon /= nlon_sfc or nlat /= nlat_sfc +! +! program history log: +! 2019-09-23 Martin Initial version. +! +! input argument list: +! +! output argument list: +! isli - sea/land/ice mask +! +! attributes: +! language: f90 +! +!$$$ + use mpimod, only: mype + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: nlat,nlon + use constants, only: zero + use module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + close_dataset, get_dim, read_vardata, get_idate_from_time_units + implicit none + +! Declare passed variables + integer(i_kind), dimension(nlat,nlon), intent( out) :: isli_anl + +! Declare local parameters + integer(i_kind),dimension(6):: idate + integer(i_kind),dimension(4):: odate + + +! Declare local variables + character(len=24) :: filename + character(len=120) :: my_name = 'READ_GFSNCSFC_ANL' + integer(i_kind) :: i,j + integer(i_kind) :: lonb, latb + real(r_single),allocatable, dimension(:) :: fhour + real(r_single), allocatable, dimension(:,:) :: work,outtmp + type(Dataset) :: sfcges + type(Dimension) :: ncdim + +!----------------------------------------------------------------------------- + + filename='sfcf06_anlgrid' + ! open the netCDF file + sfcges = open_dataset(filename) + ! get dimension sizes + ncdim = get_dim(sfcges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(sfcges, 'grid_yt'); latb = ncdim%len + + ! get time information + idate = get_idate_from_time_units(sfcges) + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + call read_vardata(sfcges, 'time', fhour) ! might need to change this to attribute later + ! depends on model changes from Jeff Whitaker + + 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)) + work = zero + +! slmsk + call read_vardata(sfcges, 'land', work) + allocate(outtmp(latb+2,lonb)) + call tran_gfsncsfc(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) + call close_dataset(sfcges) + +! +! 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_gfsncsfc_anl_(iope,isli_anl) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_gfsncsfc_anl read netcdf surface guess file with analysis resolution +! +! prgmmr: Martin org: NCEP/EMC date: 2019-09-23 +! +! abstract: read netcdf surface file at analysis grids +! +! program history log: +! 2019-09-23 Martin Initial version. +! +! 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 netcdf' + 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_gfsncsfc_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 netcdf nst surface guess file (quadratic +! Gaussin grids) without scattering to tasks +! prgmmr: Martin org: NCEP/EMC date: 2019-09-23 +! +! abstract: read netcdf surface NST file +! +! program history log: +! 2019-09-23 Martin Initial version based on sub read_nemsnst +! +! 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 +! +!$$$ + 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 module_fv3gfs_ncio, only: Dataset, Variable, Dimension, open_dataset,& + close_dataset, get_dim, read_vardata, get_idate_from_time_units + 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(6) :: idate + integer(i_kind),dimension(4) :: odate + +! Declare local variables + character(len=6) :: filename + character(len=120) :: my_name = 'READ_GFSNCNST' + integer(i_kind) :: i,j,it,latb,lonb + real(r_single),allocatable, dimension(:) :: fhour + real(r_single), dimension(nlat_sfc,nlon_sfc,nfldnst) :: xt + real(r_single), allocatable, dimension(:,:) :: work + type(Dataset) :: sfcges + type(Dimension) :: ncdim + +!----------------------------------------------------------------------------- + + do it=1,nfldnst +! read a nst file on the task + write(filename,200)ifilenst(it) +200 format('nstf',i2.2) + + ! open the netCDF file + sfcges = open_dataset(filename) + ! get dimension sizes + ncdim = get_dim(sfcges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(sfcges, 'grid_yt'); latb = ncdim%len + + ! get time information + idate = get_idate_from_time_units(sfcges) + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + call read_vardata(sfcges, 'time', fhour) ! might need to change this to attribute later + ! depends on model changes from Jeff Whitaker + + 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 +! + allocate(work(lonb,latb)) + work = zero + +! Tref + call read_vardata(sfcges, 'tref', work) + call tran_gfsncsfc(work,tref(1,1,it),lonb,latb) + +! dt_cool + call read_vardata(sfcges, 'dtcool', work) + call tran_gfsncsfc(work,dt_cool(1,1,it),lonb,latb) + +! z_c + call read_vardata(sfcges, 'zc', work) + call tran_gfsncsfc(work,z_c(1,1,it),lonb,latb) + +! xt + call read_vardata(sfcges, 'xt', work) + call tran_gfsncsfc(work,xt(1,1,it),lonb,latb) + +! xz + call read_vardata(sfcges, 'xz', work) + call tran_gfsncsfc(work,z_w(1,1,it),lonb,latb) +! +! c_0 + call read_vardata(sfcges, 'c0', work) + call tran_gfsncsfc(work,c_0(1,1,it),lonb,latb) + +! c_d + call read_vardata(sfcges, 'cd', work) + call tran_gfsncsfc(work,c_d(1,1,it),lonb,latb) + +! w_0 + call read_vardata(sfcges, 'w0', work) + call tran_gfsncsfc(work,w_0(1,1,it),lonb,latb) + +! w_d + call read_vardata(sfcges, 'wd', work) + call tran_gfsncsfc(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) + + call close_dataset(sfcges) +! End of loop over time levels + end do + end subroutine read_nst_ + + + subroutine read_gfsncnst_ (iope,tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) + +!$$$ subprogram documentation block +! . . . . +! subprogram: read_gfsnc_nst +! prgmmr: Martin org: NCEP/EMC date: 2019-09-23 +! +! abstract: read netcdf 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 netcdf' + 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_gfsncnst_ + + subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) + +!$$$ subprogram documentation block +! . . . +! subprogram: write_ncatm --- Gather, transform, and write out to netcdf +! +! prgmmr: whitaker org: oar date: 2019-10-03 +! +! 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 +! netcdf atmospheric analysis file. +! +! program history log: +! 2019-10-03 whitaker initial version +! +! 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: 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 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 netcdf, only: nf90_max_name + use module_fv3gfs_ncio, only: open_dataset, close_dataset, Dimension, Dataset,& + read_attribute, write_attribute,get_dim, create_dataset, write_vardata, read_vardata,& + get_idate_from_time_units,quantize_data,get_time_units_from_idate,has_attr,has_var + use ncepnems_io, only: error_msg + + 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_GFSNCATM' + character(len=1) :: null = ' ' + integer(i_kind),dimension(6):: idate,jdate + integer(i_kind) :: k, mm1, nlatm2, nord_int, i, j, kk, kr, nbits + integer(i_kind) :: iret, lonb, latb, levs, istatus + integer(i_kind) :: nfhour + 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), allocatable, dimension(:) :: fhour + real(r_kind),allocatable,dimension(:) :: rlats_tmp,rlons_tmp + + 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_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 + 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(:) :: rlats,rlons,clons,slons + real(r_kind),allocatable,dimension(:,:) :: grid_b,grid_b2 + real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid3, grid_c2, grid3b + real(4), allocatable, dimension(:,:) :: values_2d,values_2d_tmp + real(4), allocatable, dimension(:,:,:) :: values_3d,values_3d_tmp,ug3d,vg3d + real(4) compress_err + type(Dataset) :: atmges, atmanl + type(Dimension) :: ncdim + character(len=nf90_max_name) :: time_units + + 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) + + ! open the netCDF file + atmges = open_dataset(fname_ges,errcode=iret) + if ( iret /= 0 ) call error_msg(trim(my_name),null,null,'open',istop,iret) + ! get dimension sizes + ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len + ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + + if ( levs /= grd%nsig ) then + write(6,*) trim(my_name),': problem in data dimension background levs = ',levs,' nsig = ',grd%nsig + call stop2(103) + endif + + ! get time information + idate = get_idate_from_time_units(atmges) + call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later + ! depends on model changes from Jeff Whitaker + nfhour = fhour(1) + + atmanl = create_dataset(filename, atmges, & + copy_vardata=.true., errcode=iret) + if ( iret /= 0 ) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) + + ! Update time information (with ibdate) and write it to analysis file + 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 second + fhour = zero + + call write_vardata(atmanl, 'time', fhour) + time_units = get_time_units_from_idate(jdate) + call write_attribute(atmanl, 'units', time_units, 'time') + + ! Allocate structure arrays to hold data + allocate(values_3d_tmp(lonb,latb,levs),values_2d_tmp(lonb,latb)) + allocate(grid3b(grd%nlat,grd%nlon,1)) + 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)) + call read_vardata(atmges, 'grid_xt', rlons_tmp, errcode=iret) + call read_vardata(atmges, 'grid_yt', rlats_tmp, errcode=iret) + do j=1,latb + rlats(latb+2-j)=deg2rad*rlats_tmp(j) + enddo + rlats(1)=-half*pi + rlats(latb+2)=half*pi + do j=1,lonb + rlons(j)=deg2rad*rlons_tmp(j) + enddo + deallocate(rlons_tmp, rlats_tmp) + 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) + + endif ! if ( mype == mype_out ) + + ! Calculate delz increment for UPP + 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 + + ! 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) + 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 and delp. + 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 + call read_vardata(atmges,'pressfc',values_2d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pres','read',istop,iret) + grid_b = r0_001*values_2d + 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) + work1(kk)=grid3(i,j,1) + end do + if (has_var(atmges,'dpres')) then ! skip this if delp not in guess file. + call read_vardata(atmges,'dpres',values_3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dpres','read',istop,iret) + do k=1,grd%nsig + kr = grd%nsig-k+1 + 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) + do j=1,latb + do i=1,lonb + values_3d(i,j,kr)=values_3d(i,j,kr)+r1000*(grid_c2(latb-j+2,i,1)) + enddo + enddo + enddo + if (has_attr(atmges, 'nbits', 'dpres')) then + call read_attribute(atmges, 'nbits', nbits, 'dpres') + values_3d_tmp = values_3d + call quantize_data(values_3d_tmp, values_3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'dpres') + endif + call write_vardata(atmanl,'dpres',values_3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dpres','write',istop,iret) + endif + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk) + enddo + 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 + values_2d = grid_b + if (has_attr(atmges, 'nbits', 'pressfc')) then + call read_attribute(atmges, 'nbits', nbits, 'pressfc') + values_2d_tmp = values_2d + call quantize_data(values_2d_tmp, values_2d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'pressfc') + endif + call write_vardata(atmanl,'pressfc',values_2d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pressfc','write',istop,iret) + endif + +! u, v + if (mype==mype_out) then + if (allocated(values_3d)) deallocate(values_3d) + call read_vardata(atmges, 'ugrd', ug3d, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','read',istop,iret) + call read_vardata(atmges, 'vgrd', vg3d, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','read',istop,iret) + endif + do k=1,grd%nsig + kr = grd%nsig-k+1 + 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 + grid_b = ug3d(:,:,kr) + grid_b2 = vg3d(:,:,kr) + 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 + ug3d(:,:,kr) = grid_b + vg3d(:,:,kr) = grid_b2 + else + call load_grid(work1,grid) + ug3d(:,:,kr) = grid + call load_grid(work2,grid) + vg3d(:,:,kr) = grid + end if + endif ! mype_out + end do + ! Zonal wind + if (mype==mype_out) then + if (has_attr(atmges, 'nbits', 'ugrd')) then + call read_attribute(atmges, 'nbits', nbits, 'ugrd') + values_3d_tmp = ug3d + call quantize_data(values_3d_tmp, ug3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'ugrd') + endif + call write_vardata(atmanl,'ugrd',ug3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','write',istop,iret) + ! Meridional wind + if (has_attr(atmges, 'nbits', 'vgrd')) then + call read_attribute(atmges, 'nbits', nbits, 'vgrd') + values_3d_tmp = vg3d + call quantize_data(values_3d_tmp, vg3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'vgrd') + endif + call write_vardata(atmanl,'vgrd',vg3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','write',istop,iret) + deallocate(ug3d, vg3d) + endif + +! Thermodynamic variable + if (mype==mype_out) then + call read_vardata(atmges, 'tmp', values_3d, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop,iret) + endif + do k=1,grd%nsig + kr = grd%nsig-k+1 + 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 + grid_b=values_3d(:,:,kr) + 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 + values_3d(:,:,kr) = grid_b + else + call load_grid(work1,grid) + values_3d(:,:,kr) = grid + end if + endif + end do + if (mype==mype_out) then + if (has_attr(atmges, 'nbits', 'tmp')) then + call read_attribute(atmges, 'nbits', nbits, 'tmp') + values_3d_tmp = values_3d + call quantize_data(values_3d_tmp, values_3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'tmp') + endif + call write_vardata(atmanl,'tmp',values_3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','write',istop,iret) + endif + +! Specific humidity + if (mype==mype_out) then + call read_vardata(atmges, 'spfh', values_3d, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','read',istop,iret) + endif + do k=1,grd%nsig + kr = grd%nsig-k+1 + 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 + grid_b=values_3d(:,:,kr) + 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 + values_3d(:,:,kr) = grid_b + else + call load_grid(work1,grid) + values_3d(:,:,kr) = grid + end if + endif + end do + if (mype==mype_out) then + if (has_attr(atmges, 'nbits', 'spfh')) then + call read_attribute(atmges, 'nbits', nbits, 'spfh') + values_3d_tmp = values_3d + call quantize_data(values_3d_tmp, values_3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'spfh') + endif + call write_vardata(atmanl,'spfh',values_3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','write',istop,iret) + endif + +! Ozone + if (mype==mype_out) then + call read_vardata(atmges, 'o3mr', values_3d, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','read',istop,iret) + endif + do k=1,grd%nsig + kr = grd%nsig-k+1 + 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 + grid_b=values_3d(:,:,kr) + 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 + values_3d(:,:,kr) = grid_b + else + call load_grid(work1,grid) + values_3d(:,:,kr) = grid + end if + endif + end do + if (mype==mype_out) then + if (has_attr(atmges, 'nbits', 'o3mr')) then + call read_attribute(atmges, 'nbits', nbits, 'o3mr') + values_3d_tmp = values_3d + call quantize_data(values_3d_tmp, values_3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'o3mr') + endif + call write_vardata(atmanl,'o3mr',values_3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','write',istop,iret) + endif + +! Cloud condensate mixing ratio + if (ntracer>2 .or. ncloud>=1) then + + if (mype==mype_out) then + if (allocated(values_3d)) deallocate(values_3d) + call read_vardata(atmges, 'clwmr', ug3d, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','read',istop,iret) + call read_vardata(atmges, 'icmr', vg3d, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','read',istop,iret) + endif + + do k=1,grd%nsig + kr = grd%nsig-k+1 + 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) + 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) + if (mype == mype_out) then + grid_b = ug3d(:,:,kr) + grid_b2=vg3d(:,:,kr) + grid_b = grid_b + grid_b2 + 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) + 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)) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + 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 + ug3d(:,:,kr) = grid_b + 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 + vg3d(:,:,kr) = grid_b2 + endif !mype == mype_out + end do + if (mype==mype_out) then + if (has_attr(atmges, 'nbits', 'clwmr')) then + call read_attribute(atmges, 'nbits', nbits, 'clwmr') + values_3d_tmp = ug3d + call quantize_data(values_3d_tmp, ug3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'clwmr') + endif + call write_vardata(atmanl,'clwmr',ug3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','write',istop,iret) + if (has_attr(atmges, 'nbits', 'icmr')) then + call read_attribute(atmges, 'nbits', nbits, 'icmr') + values_3d_tmp = vg3d + call quantize_data(values_3d_tmp, vg3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'icmr') + endif + call write_vardata(atmanl,'icmr',vg3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','write',istop,iret) + deallocate(ug3d, vg3d) + endif + endif !ntracer + +! Variables needed by the Unified Post Processor (dzdt, delz, delp) + if (mype==mype_out) then + if (has_var(atmges,'delz')) then ! if delz in guess file, read it. + call read_vardata(atmges, 'delz', values_3d, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','read',istop,iret) + endif + endif + do k=1,grd%nsig + kr = grd%nsig-k+1 + 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 + if (has_var(atmges,'delz')) then + if(diff_res)then + grid_b=values_3d(:,:,kr) + 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 + values_3d(:,:,kr) = grid_b + else + call load_grid(work1,grid) + values_3d(:,:,kr) = values_3d(:,:,kr) - grid + end if + end if + endif + end do + if (mype==mype_out) then + ! if delz in guess file, write to analysis file. + if (has_var(atmges,'delz')) then + if (has_attr(atmges, 'nbits', 'delz')) then + call read_attribute(atmges, 'nbits', nbits, 'delz') + values_3d_tmp = values_3d + call quantize_data(values_3d_tmp, values_3d, nbits, compress_err) + call write_attribute(atmanl,& + 'max_abs_compression_error',compress_err,'delz') + endif + call write_vardata(atmanl,'delz',values_3d,errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','write',istop,iret) + endif + endif + +! +! Deallocate local array +! + if (mype==mype_out) then + deallocate(grid_b,grid_b2,grid_c,grid_c2,grid3,clons,slons) + deallocate(grid3b) + + call close_dataset(atmges, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),null,'close',istop,iret) + + call close_dataset(atmanl, errcode=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) +! +! Deallocate local array +! + if (allocated(values_2d)) deallocate(values_2d) + if (allocated(values_3d)) deallocate(values_3d) + if (allocated(values_2d_tmp)) deallocate(values_2d_tmp) + if (allocated(values_3d_tmp)) deallocate(values_3d_tmp) +! + write(6,'(a,'': atm anal written for lonb,latb,levs= '',3i6,'',valid hour= '',f4.1,'',idate= '',4i5)') & + trim(my_name),lonb,latb,levs,fhour(1),jdate(1:4) + endif + + end subroutine write_atm_ + + + subroutine write_sfc_ (filename,mype_sfc,dsfct) +!$$$ subprogram documentation block +! . . . +! subprogram: write_gfsncsfc --- Write surface analysis to file +! +! prgmmr: Martin org: NCEP/EMC date: 2019-09-24 +! +! abstract: This routine writes the updated surface analysis. +! +! 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: +! 2019-09-24 Martin Initial version. Based on write_nemssfc +! +! 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 +! +!$$$ 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 netcdf, only: nf90_max_name + use module_fv3gfs_ncio, only: open_dataset, close_dataset, Dimension, Dataset,& + get_dim, create_dataset, write_vardata, read_vardata,& + get_time_units_from_idate, write_attribute + + + 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_GFSNCSFC' + integer(i_kind),dimension(6):: jdate + integer(i_kind),dimension(4):: odate + integer(i_kind) :: i, j, ip1, jp1, ilat, ilon, jj, mm1 + integer(i_kind) :: nlatm2, lonb, latb + real(r_kind),allocatable,dimension(:) :: 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_single),dimension(nlon,nlat):: buffer + real(r_single),allocatable,dimension(:,:) :: buffer2,grid2 + type(Dataset) :: sfcges,sfcanl + type(Dimension) :: ncdim + character(len=nf90_max_name) :: time_units + +!***************************************************************************** + +! 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 + ! open the netCDF file + sfcges = open_dataset(fname_ges) + ! get dimension sizes + ncdim = get_dim(sfcges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(sfcges, 'grid_yt'); latb = ncdim%len + +! +! Start to write output sfc file : filename +! +! First copy entire data from fname_ges to filename, then do selective update +! + sfcanl = create_dataset(filename, sfcges, copy_vardata=.true.) +! +! 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 + + fhour = zero + odate(1) = jdate(4) !hour + odate(2) = jdate(2) !month + odate(3) = jdate(3) !day + odate(4) = jdate(1) !year + + call write_vardata(sfcanl, 'time', fhour) + time_units = get_time_units_from_idate(jdate) + call write_attribute(sfcanl, 'units', time_units, 'time') + + allocate(buffer2(lonb,latb)) + allocate(grid2(lonb,latb)) + allocate(tsea(lonb,latb)) + +! +! Only sea surface temperature will be updated in the SFC files +! + + call read_vardata(sfcges, 'tmpsfc', tsea) + + 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 + + deallocate(buffer2) + +! update tsea record + call write_vardata(sfcanl, 'tmpsfc', grid2) + + call close_dataset(sfcges) + call close_dataset(sfcanl) + + 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: Martin org: NCEP/EMC date: 2019-09-24 +! +! 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: +! 2019-09-24 Martin initial version based on routine write_nems_sfc_nst +! +! input argument list: +! dsfct - delta skin temperature +! mype_so - mpi task to write output file +! +! output argument list: +! +! attributes: +! language: f90 +! +!$$$ 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 module_fv3gfs_ncio, only: open_dataset, close_dataset, Dimension, Dataset,& + get_dim, create_dataset, write_vardata, read_vardata,& + get_time_units_from_idate, write_attribute + use netcdf, only: nf90_max_name + + 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' + integer(i_kind),dimension(7):: jdate + integer(i_kind),dimension(4):: odate + integer(i_kind) :: i, j, ip1, jp1, ilat, ilon, mm1 + integer(i_kind) :: lonb, latb, nlatm2 + integer(i_kind) :: lonb_nst, latb_nst + real(r_kind),allocatable,dimension(:) :: 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 + + type(Dataset) :: sfcges,sfcgcy,nstges,sfctsk,sfcanl,nstanl + type(Dimension) :: ncdim + character(len=nf90_max_name) :: time_units + +!***************************************************************************** + +! 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_gfsnc_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 + +! open nsst guess file + nstges = open_dataset(fname_nstges) +! open surface guess file + sfcges = open_dataset(fname_sfcges) +! open surface gcycle file + sfcgcy = open_dataset(fname_sfcgcy) + +! read a few surface guess file header records + ! get dimension sizes + ncdim = get_dim(sfcges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(sfcges, 'grid_yt'); latb = ncdim%len + +! read some nsst guess file header records (dimensions) + ! get dimension sizes + ncdim = get_dim(nstges, 'grid_xt'); lonb_nst = ncdim%len + ncdim = get_dim(nstges, 'grid_yt'); latb_nst = ncdim%len + +! 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)) + +! read slmsk in fname_sfcges to get slmsk_ges + call read_vardata(sfcges, 'land', slmsk_ges) + +! read slmsk in fname_sfcgcy to get slmsk_anl + call read_vardata(sfcgcy, 'land', slmsk_anl) +! +! 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 + + 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_GFSNC_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_GFSNC_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_gfsncsfc(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) +! + sfcanl = create_dataset(fname_sfcanl, sfcgcy, copy_vardata=.true.) + + call write_vardata(sfcanl, 'time', fhour) + time_units = get_time_units_from_idate(jdate) + call write_attribute(sfcanl, 'units', time_units, 'time') + + sfctsk = create_dataset(fname_sfctsk, sfcgcy, copy_vardata=.true.) + + call write_vardata(sfctsk, 'time', fhour) + time_units = get_time_units_from_idate(jdate) + call write_attribute(sfctsk, 'units', time_units, 'time') + +! +! copy input header info to output header info for nstanl, need to do this before nemsio_close(gfile) +! + nstanl = create_dataset(fname_nstanl, nstges, copy_vardata=.true.) + + call write_vardata(nstanl, 'time', fhour) + time_units = get_time_units_from_idate(jdate) + call write_attribute(nstanl, 'units', time_units, 'time') + +! +! 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 read_vardata(sfcges, 'tmpsfc', tsea) + +! 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 read_vardata(nstges, 'xt', xt) +! xs + call read_vardata(nstges, 'xs', xs) +! xu + call read_vardata(nstges, 'xu', xu) +! xv + call read_vardata(nstges, 'xv', xv) +! xz + call read_vardata(nstges, 'xz', xz) +! zm + call read_vardata(nstges, 'zm', zm) +! xtts + call read_vardata(nstges, 'xtts', xtts) +! xzts + call read_vardata(nstges, 'xzts', xzts) +! dt_cool + call read_vardata(nstges, 'dtcool', dt_cool) +! z_c + call read_vardata(nstges, 'zc', z_c) +! c_0 + call read_vardata(nstges, 'c0', c_0) +! c_d + call read_vardata(nstges, 'cd', c_d) +! w_0 + call read_vardata(nstges, 'w0', w_0) +! w_d + call read_vardata(nstges, 'wd', w_d) +! tref + call read_vardata(nstges, 'tref', tref) +! d_conv + call read_vardata(nstges, 'dconv', d_conv) +! ifd +! CRM - does this exist? what is it's name?? + !call read_vardata(nstges, 'ifd', ifd) +! qrain + call read_vardata(nstges, 'qrain', qrain) +! +! 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 +! + call write_vardata(sfcanl, 'tmpsfc', tsea) + write(6,100) fname_sfcanl,lonb,latb,houra,iadate(1:4) +100 format(' WRITE_GFSNCIO_SFC_NST: update tsea in ',a6,2i6,1x,f4.1,4(i4,1x)) +! +! update tsea record in sfctsk +! + call write_vardata(sfctsk, 'tmpsfc', tsea) + write(6,101) fname_sfctsk,lonb,latb,houra,iadate(1:4) +101 format(' WRITE_GFSNCIO_SFC_NST: update tsea in ',a6,2i6,1x,f4.1,4(i4,1x)) +! +! update nsst records in nstanl +! +! slmsk + call write_vardata(nstanl, 'land', slmsk_anl) +! xt + call write_vardata(nstanl, 'xt', xt) +! xs + call write_vardata(nstanl, 'xs', xs) +! xu + call write_vardata(nstanl, 'xu', xu) +! xv + call write_vardata(nstanl, 'xv', xv) +! xz + call write_vardata(nstanl, 'xz', xz) +! zm + call write_vardata(nstanl, 'zm', zm) +! xtts + call write_vardata(nstanl, 'xtts', xtts) +! xzts + call write_vardata(nstanl, 'xzts', xzts) +! z_0 + call write_vardata(nstanl, 'dtcool', dt_cool) +! z_c + call write_vardata(nstanl, 'zc', z_c) +! c_0 + call write_vardata(nstanl, 'c0', c_0) +! c_d + call write_vardata(nstanl, 'cd', c_d) +! w_0 + call write_vardata(nstanl, 'w0', w_0) +! w_d + call write_vardata(nstanl, 'wd', w_d) +! d_conv + call write_vardata(nstanl, 'dconv', d_conv) +! ifd +! CRM See above ifd issue/comment + !call write_vardata(nstanl, 'ifd', ifd) +! tref + call write_vardata(nstanl, 'tref', tref) +! qrain + call write_vardata(nstanl, 'qrain', qrain) + + write(6,200) fname_nstanl,lonb,latb,houra,iadate(1:4) +200 format(' WRITE_GFSNCIO_SFC_NST: update variables in ',a6,2i6,1x,f4.1,4(i4,1x)) + + 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) + + call close_dataset(sfcges) + call close_dataset(sfcgcy) + call close_dataset(nstges) + call close_dataset(sfcanl) + call close_dataset(nstanl) + call close_dataset(sfctsk) + + write(6,'(a,'': gfsncio 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 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_gfsncsfc(ain,aout,lonb,latb) +!$$$ subprogram documentation block +! . . . . +! subprogram: tran_gfsncsfc 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_gfsncsfc + +end module netcdfgfs_io + diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 1014c7f40e..c60eabfab1 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -437,7 +437,7 @@ module obsmod public :: perturb_fact,dtbduv_on,nsat1,obs_sub_comm,mype_diaghdr public :: lobsdiag_allocated public :: nloz_v8,nloz_v6,nloz_omi,nlco,nobskeep - public :: grids_dim,rmiss_single,nchan_total,mype_sst,mype_gps + public :: 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,iout_light,mype_light @@ -555,7 +555,7 @@ module obsmod 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 + integer(i_kind) nchan_total,ianldate integer(i_kind) ndat,ndat_types,ndat_times,nprof_gps integer(i_kind) lunobs_obs,nloz_v6,nloz_v8,nobskeep,nloz_omi integer(i_kind) nlco,use_limit @@ -871,8 +871,6 @@ subroutine init_obsmod_dflts ! related to brightness temperature and ! precipitation rate observations - grids_dim= 80 ! grid points for integration of GPS bend - nprof_gps = 0 hilbert_curve=.false. diff --git a/src/gsi/pcgsoi.f90 b/src/gsi/pcgsoi.f90 index 414c8498a3..31b1c6ac2d 100644 --- a/src/gsi/pcgsoi.f90 +++ b/src/gsi/pcgsoi.f90 @@ -132,7 +132,7 @@ subroutine pcgsoi() use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar, iwrtinc, ladtest, & iorthomax use gridmod, only: twodvar_regional - use constants, only: zero,one,five,tiny_r_kind + use constants, only: zero,one,tiny_r_kind use anberror, only: anisotropic use mpimod, only: mype use mpl_allreducemod, only: mpl_allreduce @@ -460,7 +460,7 @@ subroutine pcgsoi() 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 (b7.0_r_kind) then if (mype==0) then if (iout_6) write(6,105) gnorm(2),gsave,b write(iout_iter,105) gnorm(2),gsave,b diff --git a/src/gsi/phil.f90 b/src/gsi/phil.f90 index 6689aeedfd..733bff9286 100644 --- a/src/gsi/phil.f90 +++ b/src/gsi/phil.f90 @@ -86,7 +86,7 @@ recursive subroutine bsort_s(n1,n2,v,next,first) implicit none integer(i_kind), intent(IN ) :: n1,n2 -real(r_kind),dimension(n1:n2), intent(IN ) :: v +real(r_kind), dimension(n1:n2),intent(IN ) :: v integer(i_kind), dimension(n1:n2),intent( OUT) :: next integer(i_kind), intent( OUT) :: first !----------------------------------------------------------------------------- diff --git a/src/gsi/phil0.f90 b/src/gsi/phil0.f90 new file mode 100644 index 0000000000..8b4dcecef8 --- /dev/null +++ b/src/gsi/phil0.f90 @@ -0,0 +1,1592 @@ +! ************************************** +! * Module phil0 * +! * R. J. Purser NOAA/NCEP/EMC 2009 * +! * jim.purser@noaa.gov * +! ************************************** +! +! Module procedures pertaining to Hilbert curve transformations and +! representations. +! +! Direct dependencies +! Modules: kinds, pietc +! +!============================================================================= +module phil0 +!============================================================================= +! Several different ways of expressing location are indicated in the names +! of the routines that perform the transformations from one representation +! to another. Single and double precsion versions are also indicated by the +! suffixes _s or _d, but mostly, only the _d versions are supported. +! +! The location representations are indicated as follows: +! r: Real parameter of the Hilbert curve +! hil#: Base-# expansion of parameter r, # =4, 8, 16, or 48 for mixed base 4,8 +! dig#: Base-# digits in standard expansion of cartesian location in sq or cube +! xy*: Index (optional) of sq or cube, and Cartesian location within it. +! xs: 3D unit-Cartesian vector of point on the unit sphere +! ea: Equal-area coordinates of square map panel of cubed sphere +! gn: Gnomonic coordinates of square map panel of cubed sphere. +! +! The PUBLIC interfaces relate only to module procedures explicitly required +! by the general user; the PRIVATE ones are internally used as intermediate +! steps. +! PUBLIC: +! r_to_hil#, where # = 4,8,16: Encode the Hilbert parameter in base-#, +! or, when # = 48: mixed base 4 and 8. +! hil#_to_r: Inverse of r_to_hil# within the allowed precision. +! hil#_to_x*: Transform from Hilbert curve code to Cartesian location in +! unit square (#=4, x* = xy), cube (#=8, x*=xyz) or hypercube +! (#=16, x*=xyza). +! xy*_to_hil#: Inverse of hil#_to_xy* +! hil4_to_xs: Transform base-4 Hilbert parameter expansion to Cartesian +! 3-vector of an equal-area cubed sphere. The 0th digit of the +! Hilbert code expansion, hil, denotes the index, from 0 to 23, +! of the principal square of this mapping, these square being +! grouped in triplets around each of the 8 cube-vertices. (This +! convention was designed so that one hemisphere is filled by +! the first half of the Hilbert curve, the other hemisphere by +! the second half.) +! xs_to_hil4: The inverse of hil4_to_xs +! hil48_to_xs: Like hil4_to_xs except the mixed basis, 4, then 8, allows +! for the case of a spherical shell whose thickness, or 3rd +! dimension is invoked once the base becomes 8 instead of 4. +! But, in addition to unit 3-vector output, xs, there is also +! a real scalar output variable, r, that denotes a scaled +! radial, or vertical, coordinate variable whose resolution is +! the same as the horizontal resolution of xs when the latter +! is regarded as being composed of 24 deformed squares around +! the spherical surface. +! xs_to_hil48: Inverse of hil48_to_xs. +! +! PRIVATE: +! hil#_to_dig#: Convert from hilbert base-# expansion to ordinary Cartesian +! base-# expansion within a square (# =4), cube (# = 8) or +! hypercube (# = 16). +! dig#_to_hil#: Exact inverse of hil#_to_dig# +! dig#_to_x*: Base-# expansion (#=4, 8, 16) to real Cartesians within unit +! square (x* = x), cube (x* =xyz), hypercube (x* =xyza). +! x*_to_dig#: Inverse of dig#_to_x*. +! gn_to_ea: Cube face's gnomonic coordinates to equal-area coordinates +! ea_to_gn: Inverse of gn_to_ea. +!============================================================================= +use kinds, only: sp,dp,i_kind +use pietc, only: T,F,u0,u1,u2,o2,u4,o4,pi +implicit none +real(dp),parameter:: u8=8.0_dp,o8=u1/8.0_dp,u16=16.0_dp,o16=u1/16.0_dp,pio6=pi/6.0_dp +private +public r_to_hil4, r_to_hil8, r_to_hil16, r_to_hil48, & + hil4_to_r, hil8_to_r, hil16_to_r, hil48_to_r, & + hil4_to_xy, hil8_to_xyz, hil16_to_xyza, hil48_to_xyz, & + xy_to_hil4, xyz_to_hil8, xyza_to_hil16, xyz_to_hil48, & + hil4_to_xs, hil48_to_xs, & + xs_to_hil4, xs_to_hil48, & +! hil4_to_dig4, hil8_to_dig8, hil16_to_dig16, & +! dig4_to_hil4, dig8_to_hil8, dig16_to_hil16, & +! dig4_to_xy, dig8_to_xyz, dig16_to_xyza, & +! xy_to_dig4, xyz_to_dig8, xyza_to_dig16, & +! gn_to_ea,ea_to_gn, & + hil4_to_rz, hil8_to_rz, hil16_to_rz + +!-- Public interfaces: +interface r_to_hil4; module procedure r_to_hil4_s,r_to_hil4_d; end interface +interface r_to_hil8; module procedure r_to_hil8_d; end interface +interface r_to_hil16; module procedure r_to_hil16_d; end interface +interface r_to_hil48; module procedure r_to_hil48_d; end interface +interface hil4_to_r; module procedure hil4_to_r_d; end interface +interface hil8_to_r; module procedure hil8_to_r_d; end interface +interface hil16_to_r; module procedure hil16_to_r_d; end interface +interface hil48_to_r; module procedure hil48_to_r_d; end interface +!.. +interface hil4_to_xy; module procedure hil4_to_xy_d; end interface +interface hil8_to_xyz; module procedure hil8_to_xyz_d; end interface +interface hil16_to_xyza;module procedure hil16_to_xyza_d; end interface +interface hil48_to_xyz; module procedure hil48_to_xyz_d; end interface +!.. +interface xy_to_hil4 + module procedure xy_to_hil4z_s,xy_to_hil4z_d,xy_to_hil4_s,xy_to_hil4_d +end interface +interface xyz_to_hil8 + module procedure xyz_to_hil8z_d,xyz_to_hil8_d +end interface +interface xyza_to_hil16 + module procedure xyza_to_hil16z_d,xyza_to_hil16_d +end interface +interface xyz_to_hil48 + module procedure xyz_to_hil48_d +end interface +interface hil4_to_xs; module procedure hil4_to_xs_d; end interface +interface hil48_to_xs; module procedure hil48_to_xs_d; end interface +interface xs_to_hil4; module procedure xs_to_hil4_d; end interface +interface xs_to_hil48; module procedure xs_to_hil48_d; end interface +!-- +!-- private interfaces: +interface hil4_to_dig4; module procedure hil4_to_dig4; end interface +interface hil8_to_dig8; module procedure hil8_to_dig8; end interface +interface hil16_to_dig16; module procedure hil16_to_dig16; end interface +!.. +interface dig4_to_hil4; module procedure dig4_to_hil4; end interface +interface dig8_to_hil8; module procedure dig8_to_hil8; end interface +interface dig16_to_hil16; module procedure dig16_to_hil16; end interface +!.. +interface dig4_to_xy; module procedure dig4_to_xy_d; end interface +interface dig8_to_xyz; module procedure dig8_to_xyz_d; end interface +interface dig16_to_xyza; module procedure dig16_to_xyza_d; end interface +!.. +interface xy_to_dig4 + module procedure xy_to_dig4_s,xy_to_dig4_d +end interface +interface xyz_to_dig8 + module procedure xyz_to_dig8_s,xyz_to_dig8_d +end interface +interface xyza_to_dig16 + module procedure xyza_to_dig16_d +end interface +!.. +interface gn_to_ea ; module procedure gn_to_ea_s,gn_to_ea_d; end interface +interface ea_to_gn ; module procedure ea_to_gn_s,ea_to_gn_d; end interface +! +!== Earlier versions of hil*_to_r, still public, but deprecated +! (scheduled for future deletion): +interface hil4_to_rz; module procedure hil4_to_rz_s,hil4_to_rz_d;end interface +interface hil8_to_rz; module procedure hil8_to_rz_d; end interface +interface hil16_to_rz; module procedure hil16_to_rz_d; end interface + +contains + +!============================================================================= +subroutine r_to_hil4_s(lgen,ngen,r,hil4)! [r_to_hil4] +!============================================================================= +! Take a real number r and peel off the base-4 digits from place lgen to ngen +! putting them into hil4 and leaving r as the remainder in [0,1). Note that +! by doing things this way, we can concatenate the similar operations +! and even change bases from one link to the next. +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: lgen,ngen +real(sp), intent(inout):: r +integer(i_kind),dimension(lgen:ngen),intent( out):: hil4 +!----------------------------------------------------------------------------- +integer(i_kind):: i,j +!============================================================================= +do i=lgen,ngen + if(i>0)r=4.0_sp*r + j=r; r=r-j; hil4(i)=j +enddo +end subroutine r_to_hil4_s +!============================================================================= +subroutine r_to_hil4_d(lgen,ngen,r,hil4)! [r_to_hil4] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: lgen,ngen +real(dp), intent(inout):: r +integer(i_kind),dimension(lgen:ngen),intent( out):: hil4 +!----------------------------------------------------------------------------- +integer(i_kind):: i,j +!============================================================================= +do i=lgen,ngen + if(i>0)r=u4*r + j=r; r=r-j; hil4(i)=j +enddo +end subroutine r_to_hil4_d + +!============================================================================= +subroutine r_to_hil8_d(lgen,ngen,r,hil8)! [r_to_hil8] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: lgen,ngen +real(dp), intent(inout):: r +integer(i_kind),dimension(lgen:ngen),intent( out):: hil8 +!----------------------------------------------------------------------------- +integer(i_kind):: i,j +!============================================================================= +do i=lgen,ngen + if(i>0)r=u8*r + j=r; r=r-j; hil8(i)=j +enddo +end subroutine r_to_hil8_d + +!============================================================================= +subroutine r_to_hil16_d(lgen,ngen,r,hil16)! [r_to_hil16] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: lgen,ngen +real(dp), intent(inout):: r +integer(i_kind),dimension(lgen:ngen),intent( out):: hil16 +!----------------------------------------------------------------------------- +integer(i_kind):: i,j +!============================================================================= +do i=lgen,ngen + if(i>0)r=u16*r + j=r; r=r-j; hil16(i)=j +enddo +end subroutine r_to_hil16_d + +!============================================================================= +subroutine r_to_hil48_d(lgen,ngen4,ngen48,r,hil)! [r_to_hil48] +!============================================================================= +implicit none +integer(i_kind), intent(in ):: lgen,ngen4,ngen48 +real(dp), intent(inout):: r +integer(i_kind),dimension(lgen:ngen48),intent( out):: hil +!----------------------------------------------------------------------------- +call r_to_hil4(lgen, ngen4, r,hil(lgen:ngen4)) +call r_to_hil8(ngen4+1,ngen48,r,hil(ngen4+1:ngen48)) +end subroutine r_to_hil48_d + +!============================================================================= +subroutine hil4_to_r_d(lgen,ngen,hil,r)! [hil4_to_r] +!============================================================================= +! Be sure to define r on input ! +!============================================================================= +implicit none +integer(i_kind), intent(in ):: lgen,ngen +integer(i_kind),dimension(lgen:ngen),intent(in ):: hil +real(dp), intent(inout):: r +!----------------------------------------------------------------------------- +integer(i_kind):: i +!============================================================================= +do i=ngen,lgen,-1 + r=r+hil(i) + if(i==0)return + r=r*o4 +enddo +end subroutine hil4_to_r_d + +!============================================================================= +subroutine hil8_to_r_d(lgen,ngen,hil,r)! [hil8_to_r] +!============================================================================= +! Be sure to define r on input ! +!============================================================================= +implicit none +integer(i_kind), intent(in ):: lgen,ngen +integer(i_kind),dimension(lgen:ngen),intent(in ):: hil +real(dp), intent(inout):: r +!----------------------------------------------------------------------------- +integer(i_kind):: i +!============================================================================= +do i=ngen,lgen,-1 + r=r+hil(i) + if(i==0)return + r=r*o8 +enddo +end subroutine hil8_to_r_d + +!============================================================================= +subroutine hil16_to_r_d(lgen,ngen,hil,r)! [hil16_to_r] +!============================================================================= +! Be sure to define r on input ! +!============================================================================= +implicit none +integer(i_kind), intent(in ):: lgen,ngen +integer(i_kind),dimension(lgen:ngen),intent(in ):: hil +real(dp), intent(inout):: r +!----------------------------------------------------------------------------- +integer(i_kind) :: i +!============================================================================= +do i=ngen,lgen,-1 + r=r+hil(i) + if(i==0)return + r=r*o16 +enddo +end subroutine hil16_to_r_d + +!============================================================================= +subroutine hil48_to_r_d(lgen,ngen4,ngen48,hil,r)! [hil48_to_r] +!============================================================================= +! Be sure to define r on input ! +!============================================================================= +implicit none +integer(i_kind), intent(in ):: lgen,ngen4,ngen48 +integer(i_kind),dimension(lgen:ngen48),intent(in ):: hil +real(dp), intent(inout):: r +!============================================================================= +call hil8_to_r(ngen4+1,ngen48,hil(ngen4+1:ngen48),r) +call hil4_to_r(lgen, ngen4, hil(lgen:ngen4), r) +end subroutine hil48_to_r_d + +!============================================================================= +subroutine hil4_to_xy_d(hil4,x,y)! [hil4_to_xy] +!============================================================================= +implicit none +integer(i_kind),dimension(:),intent(in ):: hil4 +real(dp), intent(out):: x,y +!----------------------------------------------------------------------------- +real(dp) :: frac +integer(i_kind),dimension(size(hil4)):: dig4 +integer(i_kind) :: presor,ngen +!============================================================================ +dig4=hil4 +presor=0; call hil4_to_dig4(presor,dig4) +call dig4_to_xy(dig4,x,y) +ngen=size(hil4) +frac=o2**(ngen+1); x=x+frac; y=y+frac ! <- to ensure final result is unbiased +end subroutine hil4_to_xy_d + +!============================================================================= +subroutine hil8_to_xyz_d(hil8,x,y,z)! [hil8_to_xyz] +!============================================================================= +implicit none +integer(i_kind),dimension(:),intent(in ):: hil8 +real(dp), intent(out):: x,y,z +!----------------------------------------------------------------------------- +real(dp) :: frac +integer(i_kind),dimension(size(hil8)):: dig8 +integer(i_kind) :: presor,ngen +!============================================================================ +dig8=hil8 +presor=0; call hil8_to_dig8(presor,dig8) +call dig8_to_xyz(dig8,x,y,z) +ngen=size(hil8) +frac=o2**(ngen+1); x=x+frac; y=y+frac; z=z+frac ! <- final result is unbiased +end subroutine hil8_to_xyz_d + +!============================================================================= +subroutine hil16_to_xyza_d(hil16,x,y,z,a)! [hil16_to_xyza] +!============================================================================= +implicit none +integer(i_kind),dimension(:),intent(in ):: hil16 +real(dp), intent(out):: x,y,z,a +!----------------------------------------------------------------------------- +real(dp) :: frac +integer(i_kind),dimension(size(hil16)):: dig16 +integer(i_kind) :: presor,ngen +!============================================================================ +dig16=hil16 +presor=0; call hil16_to_dig16(presor,dig16) +call dig16_to_xyza(dig16,x,y,z,a) +ngen=size(hil16) +frac=o2**(ngen+1); x=x+frac; y=y+frac; z=z+frac; a=a+frac ! result is unbiased +end subroutine hil16_to_xyza_d + +!============================================================================= +subroutine hil48_to_xyz_d(ngen4,hil,x,y,z)! [hil48_to_xyz] +!============================================================================= +! Take a mixed (4 and 8) radix hilbert curve parameter, hil48, whose first +! ngen4 digits are the base-4 part, while the rest are base-8, and output +! the implied unbiased x,y,z coordinates, where x and y are in the unit square +! while z lies within [0,1/2**ngen4]. The resolution of the curve is +! 1/2**(ngen48) where ngen48=size(hil48), and to ensure the results are +! unbiased, the raw output from the final stage, dig8_to_xyz, has all the +! coordinates incremented by half the final resolution. +!============================================================================= +implicit none +integer(i_kind), intent(in ):: ngen4 +integer(i_kind),dimension(:),intent(in ):: hil +real(dp), intent(out):: x,y,z +!----------------------------------------------------------------------------- +real(dp) :: frac8,frac,x4,y4 +integer(i_kind),dimension(ngen4) :: dig4 +integer(i_kind),dimension(size(hil)-ngen4):: dig8 +integer(i_kind),dimension(0:7) :: p4to8 +integer(i_kind) :: presor,ngen48 +data p4to8/0,4,9,7,1,6,10,3/ ! Convert h4 orientation code to h8 code +!============================================================================= +ngen48=size(hil) +presor=0 +if(ngen4>0)then ! Treat the radix-4 part (if there is one) + dig4=hil(1:ngen4) + call hil4_to_dig4(presor,dig4) + call dig4_to_xy(dig4,x4,y4) +else + x4=0.0_dp; y4=0.0_dp +endif +if(ngen48>ngen4)then ! Treat the radix-8 part (if there is one) + dig8=hil(ngen4+1:ngen48) + presor=p4to8(presor) + call hil8_to_dig8(presor,dig8) + call dig8_to_xyz(dig8,x,y,z) +else + x=0.0_dp; y=0.0_dp; z=0.0_dp +endif +frac8=o2**ngen4 +frac =o2**(ngen48+1) +x=x4+frac8*x+frac; y=y4+frac8*y+frac; z= frac8*z+frac +end subroutine hil48_to_xyz_d + +!============================================================================= +subroutine xy_to_hil4_s(x,y,hil4)! [xy_to_hil4] +!============================================================================= +! Convert an (x,y)-representation of a point in the proper interior of the +! unit square to an ngen-digit base-4 representation of the parameter of +! a space-filling Hilbert curve. +!============================================================================= +implicit none +real(sp), intent(IN ):: x,y +integer(i_kind),dimension(:),intent(OUT):: hil4 +!----------------------------------------------------------------------------- +real(sp):: xr,yr +integer(i_kind) :: presor +!============================================================================= +xr=x; yr=y +call xy_to_dig4(xr,yr,hil4) +presor=0; call dig4_to_hil4(presor,hil4) +end subroutine xy_to_hil4_s +!============================================================================= +subroutine xy_to_hil4_d(x,y,hil4)! [xy_to_hil4] +!============================================================================= +! Convert an (x,y)-representation of a point in the proper interior of the +! unit square to an ngen-digit base-4 representation of the parameter of +! a space-filling Hilbert curve. +!============================================================================= +implicit none +real(dp), intent(IN ):: x,y +integer(i_kind),dimension(:),intent(OUT):: hil4 +!----------------------------------------------------------------------------- +real(dp):: xr,yr +integer(i_kind) :: presor +!============================================================================= +xr=x; yr=y +call xy_to_dig4(xr,yr,hil4) +presor=0; call dig4_to_hil4(presor,hil4) +end subroutine xy_to_hil4_d + +!============================================================================= +subroutine xyz_to_hil8_d(x,y,z,hil8)! [xyz_to_hil8] +!============================================================================= +implicit none +real(dp), intent(IN ):: x,y,z +integer(i_kind),dimension(:),intent(OUT):: hil8 +!----------------------------------------------------------------------------- +real(dp):: xr,yr,zr +integer(i_kind) :: presor +!============================================================================= +xr=x; yr=y; zr=z +call xyz_to_dig8(xr,yr,zr,hil8) +presor=0; call dig8_to_hil8(presor,hil8) +end subroutine xyz_to_hil8_d + +!============================================================================= +subroutine xyza_to_hil16_d(x,y,z,a,hil16)! [xyza_to_hil16] +!============================================================================= +implicit none +real(dp), intent(IN ):: x,y,z,a +integer(i_kind),dimension(:),intent(OUT):: hil16 +!----------------------------------------------------------------------------- +real(dp):: xr,yr,zr,ar +integer(i_kind) :: presor +!============================================================================= +xr=x; yr=y; zr=z; ar=a +call xyza_to_dig16(xr,yr,zr,ar,hil16) +presor=0; call dig16_to_hil16(presor,hil16) +end subroutine xyza_to_hil16_d + +!============================================================================= +subroutine xyz_to_hil48_d(ngen4,x,y,z,hil)! [xyz_to_hil48] +!============================================================================= +implicit none +integer(i_kind), intent(in ):: ngen4 +real(dp), intent(in ):: x,y,z +integer(i_kind),dimension(:),intent(out):: hil +!----------------------------------------------------------------------------- +real(dp) :: xr,yr,zr +integer(i_kind),dimension(0:7):: p4to8 +integer(i_kind) :: presor,ngen48 +data p4to8/0,4,9,7,1,6,10,3/ ! Convert h4 orientation code to h8 code +!============================================================================= +ngen48=size(hil) +xr=x; yr=y; zr=z*u2**ngen4 +presor=0 +if(ngen4 >0 )then ! Treat radix-4 part (if any): + call xy_to_dig4 (xr,yr, hil(1:ngen4) ) + call dig4_to_hil4(presor, hil(1:ngen4) ) +endif +presor=p4to8(presor) +if(ngen48>ngen4)then ! Treat radix-8 part (if any): + call xyz_to_dig8(xr,yr,zr,hil(ngen4+1:ngen48)) + call dig8_to_hil8(presor, hil(ngen4+1:ngen48)) +endif +end subroutine xyz_to_hil48_d + +!============================================================================= +subroutine hil4_to_xs_d(ngen,hil,xs)! [hil4_to_xs] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: ngen +integer(i_kind),dimension(0:ngen),intent(IN ):: hil +real(dp),dimension(3), intent(OUT):: xs +!----------------------------------------------------------------------------- +integer(i_kind) :: m,m6 +real(dp):: x,y,q,xx,yy +!============================================================================= +call hil4_to_xy(hil(1:ngen),x,y) +m=hil(0) +m6=mod(m,6) +select case(m6) + case(0); q=x; x=y; y=q + case(1); q=x; x=1.0_dp-y; y=q + case(2); x=1.0_dp-x; y=1.0_dp-y + case(3); x=x; y=1.0_dp-y + case(4); q=x; x=1.0_dp-y; y=1.0_dp-q + case(5); q=x; x=y; y=1.0_dp-q +end select +call ea_to_gn(x,y,xx,yy) +x=xx; y=yy +select case(m) + case(1,2,9,10,13,14,21,22); xs(1)= x + case(3,4,7, 8,15,16,19,20); xs(1)=-x + case(0,11,12,23); xs(1)= 1.0_dp + case(5, 6,17,18); xs(1)=-1.0_dp +end select +select case(m) + case(6,11,12,17); xs(2)= x + case(0,5,18,23); xs(2)=-x + case(7,10,13,16); xs(2)= y + case(1,4,19,22); xs(2)=-y + case(8,9,14,15); xs(2)= 1.0_dp + case(2,3,20,21); xs(2)=-1.0_dp +end select +select case(m) + case(0,2,3,5,6,8,9,11); xs(3)= y + case(12,14,15,17,18,20,21,23); xs(3)=-y + case(1,4,7,10); xs(3)= 1.0_dp + case(13,16,19,22); xs(3)=-1.0_dp +end select +q=sqrt( dot_product(xs,xs) ); xs=xs/q +end subroutine hil4_to_xs_d + +!============================================================================= +subroutine hil48_to_xs_d(ngen4,ngen48,hil,xs,r)! [hil48_to_xs] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: ngen4,ngen48 +integer(i_kind),dimension(0:ngen48),intent(IN ):: hil +real(dp),dimension(3), intent(OUT):: xs +real(dp), intent(out):: r +!----------------------------------------------------------------------------- +integer(i_kind) :: m,m6 +real(dp):: x,y,q,xx,yy +!============================================================================= +call hil48_to_xyz(ngen4,hil(1:ngen48),x,y,r) +m=hil(0); m6=mod(m,6) +select case(m6) + case(0); q=x; x=y; y=q + case(1); q=x; x=1.0_dp-y; y=q + case(2); x=1.0_dp-x; y=1.0_dp-y + case(3); x=x; y=1.0_dp-y + case(4); q=x; x=1.0_dp-y; y=1.0_dp-q + case(5); q=x; x=y; y=1.0_dp-q +end select +call ea_to_gn(x,y,xx,yy) +x=xx; y=yy +select case(m) + case(1,2,9,10,13,14,21,22); xs(1)= x + case(3,4,7, 8,15,16,19,20); xs(1)=-x + case(0,11,12,23); xs(1)= 1.0_dp + case(5, 6,17,18); xs(1)=-1.0_dp +end select +select case(m) + case(6,11,12,17); xs(2)= x + case(0,5,18,23); xs(2)=-x + case(7,10,13,16); xs(2)= y + case(1,4,19,22); xs(2)=-y + case(8,9,14,15); xs(2)= 1.0_dp + case(2,3,20,21); xs(2)=-1.0_dp +end select +select case(m) + case(0,2,3,5,6,8,9,11); xs(3)= y + case(12,14,15,17,18,20,21,23); xs(3)=-y + case(1,4,7,10); xs(3)= 1.0_dp + case(13,16,19,22); xs(3)=-1.0_dp +end select +q=sqrt( dot_product(xs,xs) ); xs=xs/q +end subroutine hil48_to_xs_d + +!============================================================================= +subroutine xs_to_hil4_d(ngen,xs,hil)! [xs_to_hil4] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: ngen +real(dp),dimension(3), intent(IN ):: xs +integer(i_kind), dimension(0:ngen),intent(OUT):: hil +!----------------------------------------------------------------------------- +real(dp) :: x,y,z,ax,ay,az,q,xx,yy +integer(i_kind) :: k,L,m,m6 +integer(i_kind),dimension(0:7) :: Ltab,ktab +data Ltab/1,0,2,0,1,1,2,1/ +data ktab/6,7,5,4,1,0,2,3/ +!============================================================================= +x=xs(1); ax=abs(x) +y=xs(2); ay=abs(y) +z=xs(3); az=abs(z) +k=0; if( x>0 )k=k+1; if( y>0 )k=k+2; if( z>0 )k=k+4 +L=0; if(ax>ay)L=L+1; if(ay>az)L=L+2; if(az>ax)L=L+4 +L=Ltab(L) +k=ktab(k) +if(mod(k,2)==0)then; m=k*3+L +else; m=k*3+2-L +endif +hil(0)=m +select case(m) + case(0,5,6,11,12,17,18,23); x=ay/ax; y=az/ax + case(2,3,8,9,14,15,20,21); x=ax/ay; y=az/ay + case(1,4,7,10,13,16,19,22); x=ax/az; y=ay/az +end select + +m6=mod(m,6) +call gn_to_ea(x,y,xx,yy); x=xx; y=yy + +select case(m6) + case(0); q=x; x=y; y=q + case(1); q=x; x=y; y=1.0_dp-q + case(2); x=1.0_dp-x; y=1.0_dp-y + case(3); x=x; y=1.0_dp-y + case(4); q=x; x=1.0_dp-y; y=1.0_dp-q + case(5); q=x; x=1.0_dp-y; y=q +end select +call xy_to_hil4(x,y,hil(1:ngen)) +end subroutine xs_to_hil4_d + +!============================================================================= +subroutine xs_to_hil48_d(ngen4,ngen48,xs,r,hil)! [xs_to_hil48] +!============================================================================= +implicit none +integer(i_kind), intent(in ):: ngen4,ngen48 +real(dp),dimension(3), intent(in ):: xs +real(dp), intent(in ):: r +integer(i_kind), dimension(0:ngen48),intent(out):: hil +!----------------------------------------------------------------------------- +real(dp) :: x,y,z,ax,ay,az,q,xx,yy +integer(i_kind) :: k,L,m,m6 +integer(i_kind),dimension(0:7) :: Ltab,ktab +data Ltab/1,0,2,0,1,1,2,1/ +data ktab/6,7,5,4,1,0,2,3/ +!============================================================================= +x=xs(1); ax=abs(x) +y=xs(2); ay=abs(y) +z=xs(3); az=abs(z) +k=0; if( x>0 )k=k+1; if( y>0 )k=k+2; if( z>0 )k=k+4 +L=0; if(ax>ay)L=L+1; if(ay>az)L=L+2; if(az>ax)L=L+4 +L=Ltab(L) +k=ktab(k) +if(mod(k,2)==0)then; m=k*3+L +else; m=k*3+2-L +endif +hil(0)=m +select case(m) + case(0,5,6,11,12,17,18,23); x=ay/ax; y=az/ax + case(2,3,8,9,14,15,20,21); x=ax/ay; y=az/ay + case(1,4,7,10,13,16,19,22); x=ax/az; y=ay/az +end select + +! Insert equal-area transformation of (x,y) here +m6=mod(m,6) +call gn_to_ea(x,y,xx,yy) ; x=xx; y=yy + +select case(m6) + case(0); q=x; x=y; y=q + case(1); q=x; x=y; y=1.0_dp-q + case(2); x=1.0_dp-x; y=1.0_dp-y + case(3); x=x; y=1.0_dp-y + case(4); q=x; x=1.0_dp-y; y=1.0_dp-q + case(5); q=x; x=1.0_dp-y; y=q +end select +call xyz_to_hil48(ngen4,x,y,r,hil(1:ngen48)) +end subroutine xs_to_hil48_d + +!----------------- +! Private routines: +!============================================================================= +subroutine hil4_to_dig4(presor,hil4)! [hil4_to_dig4] +!============================================================================= +implicit none +integer(i_kind), intent(inout):: presor +integer(i_kind),dimension(:),intent(inout):: hil4 +!----------------------------------------------------------------------------- +integer(i_kind),dimension(0:3, 0:7):: dtable,ptable +integer(i_kind) :: igen,h +data dtable/0,2,3,1, 1,0,2,3, 3,1,0,2, 2,3,1,0, & + 0,1,3,2, 2,0,1,3, 3,2,0,1, 1,3,2,0/ +data ptable/4,0,0,6, 7,1,1,5, 6,2,2,4, 5,3,3,7, & + 0,4,4,2, 3,5,5,1, 2,6,6,0, 1,7,7,3/ +!============================================================================= +do igen=1,size(hil4) + h=hil4(igen) + hil4(igen)=dtable(h,presor) + presor =ptable(h,presor) +enddo +end subroutine hil4_to_dig4 + +!============================================================================= +subroutine hil8_to_dig8(presor,hil8)! [hil8_to_dig8] +!============================================================================= +implicit none +integer(i_kind), intent(inout):: presor +integer(i_kind),dimension(:),intent(inout):: hil8 +!----------------------------------------------------------------------------- +integer(i_kind),dimension(0:7,0:23):: dtable,ptable +integer(i_kind) :: igen,h +data dtable/ & +0,2,6,4,5,7,3,1, 0,4,5,1,3,7,6,2, 0,1,3,2,6,7,5,4, & +1,5,7,3,2,6,4,0, 1,0,4,5,7,6,2,3, 1,3,2,0,4,6,7,5, & +2,6,4,0,1,5,7,3, 2,3,7,6,4,5,1,0, 2,0,1,3,7,5,4,6, & +3,1,5,7,6,4,0,2, 3,7,6,2,0,4,5,1, 3,2,0,1,5,4,6,7, & +4,0,2,6,7,3,1,5, 4,5,1,0,2,3,7,6, 4,6,7,5,1,3,2,0, & +5,7,3,1,0,2,6,4, 5,1,0,4,6,2,3,7, 5,4,6,7,3,2,0,1, & +6,4,0,2,3,1,5,7, 6,2,3,7,5,1,0,4, 6,7,5,4,0,1,3,2, & +7,3,1,5,4,0,2,6, 7,6,2,3,1,0,4,5, 7,5,4,6,2,0,1,3/ +data ptable/ & + 1, 2, 2,18,18,17,17,10, 2, 0, 0,16,16, 9, 9,20, 0, 1, 1,11,11,19,19,15, & + 5, 4, 4,21,21, 7, 7,14, 3, 5, 5,13,13,23,23, 6, 4, 9, 9, 8, 8,12,12,22, & + 8, 7, 7,12,12, 4, 4,23, 6, 8, 8,22,22,14,14, 3, 7, 6, 6, 5, 5,21,21,13, & +10,11,11,15,15,20,20, 1, 11, 9, 9,19,19, 0, 0,17, 9,10,10, 2, 2,16,16,18, & +14,13,13, 6, 6,22,22, 5, 12,14,14, 4, 4, 8, 8,21, 13,12,12,23,23,33, 3, 7, & +16,17,17, 9, 9, 2, 2,19, 17,15,15, 1, 1,18,18,11, 15,16,16,20,20,10,10, 0, & +19,20,20, 0, 0,11,11,16, 20,18,18,10,10,15,15, 2, 18,19,19,17,17, 1, 1, 9, & +23,22,22, 3, 3,13,13, 8, 21,23,23, 7, 7, 5, 5,12, 22,21,21,14,14, 6, 6, 4/ +!============================================================================= +do igen=1,size(hil8) + h=hil8(igen) + hil8(igen)=dtable(h,presor) + presor =ptable(h,presor) +enddo +end subroutine hil8_to_dig8 + +!============================================================================= +subroutine hil16_to_dig16(presor,hil16)! [hil16_to_dig16] +!============================================================================= +implicit none +integer(i_kind), intent(inout):: presor +integer(i_kind),dimension(:),intent(inout):: hil16 +!----------------------------------------------------------------------------- +integer(i_kind),dimension(0:15,0:63):: dtable,ptable +integer(i_kind) :: igen,h +data dtable/ & + 0, 8,12, 4, 6,14,10, 2, 3,11,15, 7, 5,13, 9, 1, & + 0, 8, 9, 1, 5,13,12, 4, 6,14,15, 7, 3,11,10, 2, & + 0, 8,10, 2, 3,11, 9, 1, 5,13,15, 7, 6,14,12, 4, & + 0, 1, 3, 2, 6, 7, 5, 4,12,13,15,14,10,11, 9, 8, & + 1, 9,11, 3, 7,15,13, 5, 4,12,14, 6, 2,10, 8, 0, & + 1, 9,13, 5, 4,12, 8, 0, 2,10,14, 6, 7,15,11, 3, & + 1, 9, 8, 0, 2,10,11, 3, 7,15,14, 6, 4,12,13, 5, & + 1, 3, 2, 0, 4, 6, 7, 5,13,15,14,12, 8,10,11, 9, & + 2,10, 8, 0, 4,12,14, 6, 7,15,13, 5, 1, 9,11, 3, & + 2,10,14, 6, 7,15,11, 3, 1, 9,13, 5, 4,12, 8, 0, & + 2,10,11, 3, 1, 9, 8, 0, 4,12,13, 5, 7,15,14, 6, & + 2, 0, 1, 3, 7, 5, 4, 6,14,12,13,15,11, 9, 8,10, & + 3,11,15, 7, 5,13, 9, 1, 0, 8,12, 4, 6,14,10, 2, & + 3,11,10, 2, 6,14,15, 7, 5,13,12, 4, 0, 8, 9, 1, & + 3,11, 9, 1, 0, 8,10, 2, 6,14,12, 4, 5,13,15, 7, & + 3, 2, 0, 1, 5, 4, 6, 7,15,14,12,13, 9, 8,10,11, & + 4,12,14, 6, 2,10, 8, 0, 1, 9,11, 3, 7,15,13, 5, & + 4,12, 8, 0, 1, 9,13, 5, 7,15,11, 3, 2,10,14, 6, & + 4,12,13, 5, 7,15,14, 6, 2,10,11, 3, 1, 9, 8, 0, & + 4, 6, 7, 5, 1, 3, 2, 0, 8,10,11, 9,13,15,14,12, & + 5,13, 9, 1, 3,11,15, 7, 6,14,10, 2, 0, 8,12, 4, & + 5,13,12, 4, 0, 8, 9, 1, 3,11,10, 2, 6,14,15, 7, & + 5,13,15, 7, 6,14,12, 4, 0, 8,10, 2, 3,11, 9, 1, & + 5, 4, 6, 7, 3, 2, 0, 1, 9, 8,10,11,15,14,12,13, & + 6,14,10, 2, 0, 8,12, 4, 5,13, 9, 1, 3,11,15, 7, & + 6,14,15, 7, 3,11,10, 2, 0, 8, 9, 1, 5,13,12, 4, & + 6,14,12, 4, 5,13,15, 7, 3,11, 9, 1, 0, 8,10, 2, & + 6, 7, 5, 4, 0, 1, 3, 2,10,11, 9, 8,12,13,15,14, & + 7,15,13, 5, 1, 9,11, 3, 2,10, 8, 0, 4,12,14, 6, & + 7,15,11, 3, 2,10,14, 6, 4,12, 8, 0, 1, 9,13, 5, & + 7,15,14, 6, 4,12,13, 5, 1, 9, 8, 0, 2,10,11, 3, & + 7, 5, 4, 6, 2, 0, 1, 3,11, 9, 8,10,14,12,13,15, & + 8, 0, 2,10,14, 6, 4,12,13, 5, 7,15,11, 3, 1, 9, & + 8, 0, 4,12,13, 5, 1, 9,11, 3, 7,15,14, 6, 2,10, & + 8, 0, 1, 9,11, 3, 2,10,14, 6, 7,15,13, 5, 4,12, & + 8,10,11, 9,13,15,14,12, 4, 6, 7, 5, 1, 3, 2, 0, & + 9, 1, 5,13,15, 7, 3,11,10, 2, 6,14,12, 4, 0, 8, & + 9, 1, 0, 8,12, 4, 5,13,15, 7, 6,14,10, 2, 3,11, & + 9, 1, 3,11,10, 2, 0, 8,12, 4, 6,14,15, 7, 5,13, & + 9, 8,10,11,15,14,12,13, 5, 4, 6, 7, 3, 2, 0, 1, & +10, 2, 6,14,12, 4, 0, 8, 9, 1, 5,13,15, 7, 3,11, & +10, 2, 3,11,15, 7, 6,14,12, 4, 5,13, 9, 1, 0, 8, & +10, 2, 0, 8, 9, 1, 3,11,15, 7, 5,13,12, 4, 6,14, & +10,11, 9, 8,12,13,15,14, 6, 7, 5, 4, 0, 1, 3, 2, & +11, 3, 1, 9,13, 5, 7,15,14, 6, 4,12, 8, 0, 2,10, & +11, 3, 7,15,14, 6, 2,10, 8, 0, 4,12,13, 5, 1, 9, & +11, 3, 2,10, 8, 0, 1, 9,13, 5, 4,12,14, 6, 7,15, & +11, 9, 8,10,14,12,13,15, 7, 5, 4, 6, 2, 0, 1, 3, & +12, 4, 0, 8,10, 2, 6,14,15, 7, 3,11, 9, 1, 5,13, & +12, 4, 5,13, 9, 1, 0, 8,10, 2, 3,11,15, 7, 6,14, & +12, 4, 6,14,15, 7, 5,13, 9, 1, 3,11,10, 2, 0, 8, & +12,13,15,14,10,11, 9, 8, 0, 1, 3, 2, 6, 7, 5, 4, & +13, 5, 7,15,11, 3, 1, 9, 8, 0, 2,10,14, 6, 4,12, & +13, 5, 1, 9, 8, 0, 4,12,14, 6, 2,10,11, 3, 7,15, & +13, 5, 4,12,14, 6, 7,15,11, 3, 2,10, 8, 0, 1, 9, & +13,15,14,12, 8,10,11, 9, 1, 3, 2, 0, 4, 6, 7, 5, & +14, 6, 4,12, 8, 0, 2,10,11, 3, 1, 9,13, 5, 7,15, & +14, 6, 2,10,11, 3, 7,15,13, 5, 1, 9, 8, 0, 4,12, & +14, 6, 7,15,13, 5, 4,12, 8, 0, 1, 9,11, 3, 2,10, & +14,12,13,15,11, 9, 8,10, 2, 0, 1, 3, 7, 5, 4, 6, & +15, 7, 3,11, 9, 1, 5,13,12, 4, 0, 8,10, 2, 6,14, & +15, 7, 6,14,10, 2, 3,11, 9, 1, 0, 8,12, 4, 5,13, & +15, 7, 5,13,12, 4, 6,14,10, 2, 0, 8, 9, 1, 3,11, & +15,14,12,13, 9, 8,10,11, 3, 2, 0, 1, 5, 4, 6, 7/ +data ptable/ & + 3, 2, 2,49,49,26,26,40,40,14,14,61,61,22,22,39,& + 3, 0, 0,38,38,20,20,49,49,24,24,62,62,12,12,43,& + 3, 1, 1,40,40,13,13,38,38,21,21,60,60,25,25,51,& + 0, 1, 1,14,14,25,25,23,23,49,49,62,62,41,41,36,& + 7, 5, 5,46,46,29,29,52,52,17,17,58,58, 9, 9,35,& + 7, 6, 6,52,52,18,18,33,33,10,10,56,56,30,30,47,& + 7, 4, 4,33,33, 8, 8,46,46,28,28,57,57,16,16,55,& + 5, 4, 4,10,10,16,16,31,31,52,52,58,58,32,32,45,& +11, 9, 9,34,34,17,17,56,56,29,29,54,54, 5, 5,47,& +11,10,10,56,56,30,30,45,45, 6, 6,52,52,18,18,35,& +11, 8, 8,45,45, 4, 4,34,34,16,16,53,53,28,28,59,& + 9, 8, 8, 6, 6,28,28,19,19,56,56,54,54,44,44,33,& +15,14,14,61,61,22,22,36,36, 2, 2,49,49,26,26,43,& +15,12,12,42,42,24,24,61,61,20,20,50,50, 0, 0,39,& +15,13,13,36,36, 1, 1,42,42,25,25,48,48,21,21,63,& +12,13,13, 2, 2,21,21,27,27,61,61,50,50,37,37,40,& +19,17,17,58,58, 9, 9,32,32, 5, 5,46,46,29,29,55,& +19,18,18,32,32, 6, 6,53,53,30,30,44,44,10,10,59,& +19,16,16,53,53,28,28,58,58, 8, 8,45,45, 4, 4,35,& +17,16,16,30,30, 4, 4,11,11,32,32,46,46,52,52,57,& +23,22,22,37,37,14,14,60,60,26,26,41,41, 2, 2,51,& +23,20,20,50,50, 0, 0,37,37,12,12,42,42,24,24,63,& +23,21,21,60,60,25,25,50,50, 1, 1,40,40,13,13,39,& +20,21,21,26,26,13,13, 3, 3,37,37,42,42,61,61,48,& +27,26,26,41,41, 2, 2,48,48,22,22,37,37,14,14,63,& +27,24,24,62,62,12,12,41,41, 0, 0,38,38,20,20,51,& +27,25,25,48,48,21,21,62,62,13,13,36,36, 1, 1,43,& +24,25,25,22,22, 1, 1,15,15,41,41,38,38,49,49,60,& +31,29,29,54,54, 5, 5,44,44, 9, 9,34,34,17,17,59,& +31,30,30,44,44,10,10,57,57,18,18,32,32, 6, 6,55,& +31,28,28,57,57,16,16,54,54, 4, 4,33,33, 8, 8,47,& +29,28,28,18,18, 8, 8, 7, 7,44,44,34,34,56,56,53,& +35,33,33,10,10,57,57,16,16,53,53,30,30,45,45, 7,& +35,34,34,16,16,54,54, 5, 5,46,46,28,28,58,58,11,& +35,32,32, 5, 5,44,44,10,10,56,56,29,29,52,52,19,& +33,32,32,46,46,52,52,59,59,16,16,30,30, 4, 4, 9,& +39,38,38,21,21,62,62,12,12,42,42,25,25,50,50, 3,& +39,36,36, 2, 2,48,48,21,21,60,60,26,26,40,40,15,& +39,37,37,12,12,41,41, 2, 2,49,49,24,24,61,61,23,& +36,37,37,42,42,61,61,51,51,21,21,26,26,13,13, 0,& +43,42,42,25,25,50,50, 0, 0,38,38,21,21,62,62,15,& +43,40,40,14,14,60,60,25,25,48,48,22,22,36,36, 3,& +43,41,41, 0, 0,37,37,14,14,61,61,20,20,49,49,27,& +40,41,41,38,38,49,49,63,63,25,25,22,22, 1, 1,12,& +47,45,45, 6, 6,53,53,28,28,57,57,18,18,33,33,11,& +47,46,46,28,28,58,58, 9, 9,34,34,16,16,54,54, 7,& +47,44,44, 9, 9,32,32, 6, 6,52,52,17,17,56,56,31,& +45,44,44,34,34,56,56,55,55,28,28,18,18, 8, 8, 5,& +51,50,50, 1, 1,42,42,24,24,62,62,13,13,38,38,23,& +51,48,48,22,22,36,36, 1, 1,40,40,14,14,60,60,27,& +51,49,49,24,24,61,61,22,22,37,37,12,12,41,41, 3,& +48,49,49,62,62,41,41,39,39, 1, 1,14,14,25,25,20,& +55,53,53,30,30,45,45, 4, 4,33,33,10,10,57,57,19,& +55,54,54, 4, 4,34,34,17,17,58,58, 8, 8,46,46,31,& +55,52,52,17,17,56,56,30,30,44,44, 9, 9,32,32, 7,& +53,52,52,58,58,32,32,47,47, 4, 4,10,10,16,16,29,& +59,57,57,18,18,33,33, 8, 8,45,45, 6, 6,53,53,31,& +59,58,58, 8, 8,46,46,29,29,54,54, 4, 4,34,34,19,& +59,56,56,29,29,52,52,18,18,32,32, 5, 5,44,44,11,& +57,56,56,54,54,44,44,35,35, 8, 8, 6, 6,28,28,17,& +63,62,62,13,13,38,38,20,20,50,50, 1, 1,42,42,27,& +63,60,60,26,26,40,40,13,13,36,36, 2, 2,48,48,23,& +63,61,61,20,20,49,49,26,26,41,41, 0, 0,37,37,15,& +60,61,61,50,50,37,37,43,43,13,13, 2, 2,21,21,24/ +!============================================================================= +do igen=1,size(hil16) + h=hil16(igen) + hil16(igen)=dtable(h,presor) + presor =ptable(h,presor) +enddo +end subroutine hil16_to_dig16 + +!============================================================================= +subroutine dig4_to_hil4(presor,hil4)! [dig4_to_hil4] +!============================================================================= +! On input, hil4 contains the ngen base-4 digits defining the location of the +! target point in the unit square, and on output, it will contain the first +! ngen base-4 digits of the corresponding parameter, in [0,1), of the +! Hilbert curve. On input, presor contains the orientation code of the whole +! curve; on output, it contains the orientation code of the final segment. +! The orientation code is identified with the oriented edge segments of the +! unit square in the following way: +! ORIENTATION CODE EDGE SEGMENT +! 0 (0,0)-->(1,0) +! 1 (1,0)-->(1,1) +! 2 (1,1)-->(0,1) +! 3 (0,1)-->(1,0) +! 4 (0,0)-->(0,1) +! 5 (0,1)-->(1,1) +! 6 (1,1)-->(1,0) +! 7 (1,0)-->(0,0) +!============================================================================= +implicit none +integer(i_kind), intent(inout):: presor +integer(i_kind),dimension(:),intent(inout):: hil4 +!----------------------------------------------------------------------------- +integer(i_kind),dimension(0:3, 0:7) :: hil4table, presortable +integer(i_kind) :: igen,j +data hil4table /0,3,1,2, 1,0,2,3, 2,1,3,0, 3,2,0,1, & + 0,1,3,2, 1,2,0,3, 2,3,1,0, 3,0,2,1/ +data presortable/4,6,0,0, 1,7,1,5, 2,2,4,6, 7,3,5,3, & + 0,4,2,4, 5,5,3,1, 6,0,6,2, 3,1,7,7/ +!============================================================================= +! At successive refinements, update the present orientation and refine the +! segment on the hilbert curve according to the quadrant of the present +! square occupied by the next generation of refinement's square: +do igen=1,size(hil4) + j=hil4(igen) + hil4(igen)=hil4table (j,presor) + presor =presortable(j,presor) +enddo +end subroutine dig4_to_hil4 + +!============================================================================= +subroutine dig8_to_hil8(presor,hil8)! [dig8_to_hil8] +!============================================================================= +! Like dig4_to_hil4, but for a cube. Orientation codes now run from 0 thru +! 23 and are grouped in triplets according to the vertex the associated edge +! begins with; within each triplet, the orientations are in the x, y, z order. +! The path of 8 stations through the 2*2*2 cube associated with overall +! orientation p is given by the array, hil8table(:,p); by finding the "0" +! and the "7" in this path, one can locate the path start and endpoint, and +! hence interpret the orientation that p refers to. +!============================================================================= +implicit none +integer(i_kind), intent(inout):: presor +integer(i_kind),dimension(:),intent(inout):: hil8 +!----------------------------------------------------------------------------- +integer(i_kind),dimension(0:7, 0:23) :: hil8table, presortable +integer(i_kind) :: igen,j +data hil8table / & + 0,7,1,6,3,4,2,5, 0,3,7,4,1,2,6,5, 0,1,3,2,7,6,4,5, & + 7,0,4,3,6,1,5,2, 1,0,6,7,2,3,5,4, 3,0,2,1,4,7,5,6, & + 3,4,0,7,2,5,1,6, 7,6,0,1,4,5,3,2, 1,2,0,3,6,5,7,4, & + 6,1,7,0,5,2,4,3, 4,7,3,0,5,6,2,1, 2,3,1,0,5,4,6,7, & + 1,6,2,5,0,7,3,4, 3,2,4,5,0,1,7,6, 7,4,6,5,0,3,1,2, & + 4,3,5,2,7,0,6,1, 2,1,5,6,3,0,4,7, 6,7,5,4,1,0,2,3, & + 2,5,3,4,1,6,0,7, 6,5,1,2,7,4,0,3, 4,5,7,6,3,2,0,1, & + 5,2,6,1,4,3,7,0, 5,4,2,3,6,7,1,0, 5,6,4,7,2,1,3,0/ +data presortable/ & + 1,10, 2,17,18,18, 2,17, 2,16,20,16, 0, 0, 9, 9, 0, 1,11, 1,15,19,11,19, & +14, 5,21,21, 7, 4, 7, 4, 5, 3,23, 6, 5,13,23,13, 8, 4, 9, 9, 8,22,12,12, & +12,12, 8,23, 7, 4, 7, 4, 3,14, 6, 8,22,14,22, 8, 6, 6, 7, 5,21,21,13, 5, & +20,11, 1,10,20,11,15,15, 19,17,19,11, 0, 0, 9, 9, 10, 2,10, 9,16, 2,16,18, & +13,22,13,22,14, 5, 6, 6, 4,14, 4, 8,12,14,21, 8, 7,23, 3, 3,13,23,12,12, & + 9, 9, 2,17,19,16, 2,17, 15,15,18,18, 1,17, 1,11, 10, 0,10,20,16,15,16,20, & +20,11, 0, 0,20,11,19,16, 15,15,18,18, 2,10,20,10, 17, 1, 9, 1,17,19,18,19, & +13,22,13,22, 3, 3, 8,23, 5, 7,23, 7, 5,12,23,21, 6, 6,14, 4,21,21,14,22/ +!============================================================================= +! At successive refinements, update the present orientation and refine the +! segment on the hilbert curve according to the quadrant of the present +! square occupied by the next generation of refinement's cube: +do igen=1,size(hil8) + j=hil8(igen) + hil8(igen)=hil8table (j,presor) + presor =presortable(j,presor) +enddo +end subroutine dig8_to_hil8 + +!============================================================================= +subroutine dig16_to_hil16(presor,hil16)! [dig16_to_hil16] +!============================================================================= +! Like dig4_to_hil4, but for a 4D hypercube. +!============================================================================= +implicit none +integer(i_kind), intent(inout):: presor +integer(i_kind),dimension(:),intent(inout):: hil16 +!----------------------------------------------------------------------------- +integer(i_kind),dimension(0:15, 0:63) :: hil16table,presortable +integer(i_kind) :: igen,j +data hil16table / & +0,15,7,8,3,12,4,11,1,14,6,9,2,13,5,10, 0,3,15,12,7,4,8,11,1,2,14,13,6,5,9,10,& +0,7,3,4,15,8,12,11,1,6,2,5,14,9,13,10, 0,1,3,2,7,6,4,5,15,14,12,13,8,9,11,10,& +15,0,12,3,8,7,11,4,14,1,13,2,9,6,10,5, 7,0,8,15,4,3,11,12,6,1,9,14,5,2,10,13,& +3,0,4,7,12,15,11,8,2,1,5,6,13,14,10,9, 3,0,2,1,4,7,5,6,12,15,13,14,11,8,10,9,& +3,12,0,15,4,11,7,8,2,13,1,14,5,10,6,9, 15,8,0,7,12,11,3,4,14,9,1,6,13,10,2,5,& +7,4,0,3,8,11,15,12,6,5,1,2,9,10,14,13, 1,2,0,3,6,5,7,4,14,13,15,12,9,10,8,11,& +8,7,15,0,11,4,12,3,9,6,14,1,10,5,13,2, 12,15,3,0,11,8,4,7,13,14,2,1,10,9,5,6,& +4,3,7,0,11,12,8,15,5,2,6,1,10,13,9,14, 2,3,1,0,5,4,6,7,13,12,14,15,10,11,9,8,& +7,8,4,11,0,15,3,12,6,9,5,10,1,14,2,13, 3,4,12,11,0,7,15,8,2,5,13,10,1,6,14,9,& +15,12,8,11,0,3,7,4,14,13,9,10,1,2,6,5, 7,4,6,5,0,3,1,2,8,11,9,10,15,12,14,13,& +12,3,11,4,15,0,8,7,13,2,10,5,14,1,9,6, 4,7,11,8,3,0,12,15,5,6,10,9,2,1,13,14,& +8,15,11,12,7,0,4,3,9,14,10,13,6,1,5,2, 6,7,5,4,1,0,2,3,9,8,10,11,14,15,13,12,& +4,11,3,12,7,8,0,15,5,10,2,13,6,9,1,14, 8,11,7,4,15,12,0,3,9,10,6,5,14,13,1,2,& +12,11,15,8,3,4,0,7,13,10,14,9,2,5,1,6, 4,5,7,6,3,2,0,1,11,10,8,9,12,13,15,14,& +11,4,8,7,12,3,15,0,10,5,9,6,13,2,14,1, 11,12,4,3,8,15,7,0,10,13,5,2,9,14,6,1,& +11,8,12,15,4,7,3,0,10,9,13,14,5,6,2,1, 5,6,4,7,2,1,3,0,10,9,11,8,13,14,12,15,& +1,14,2,13,6,9,5,10,0,15,3,12,7,8,4,11, 1,6,14,9,2,5,13,10,0,7,15,8,3,4,12,11,& +1,2,6,5,14,13,9,10,0,3,7,4,15,12,8,11, 15,12,14,13,8,11,9,10,0,3,1,2,7,4,6,5,& +14,1,9,6,13,2,10,5,15,0,8,7,12,3,11,4, 2,1,13,14,5,6,10,9,3,0,12,15,4,7,11,8,& +6,1,5,2,9,14,10,13,7,0,4,3,8,15,11,12, 14,15,13,12,9,8,10,11,1,0,2,3,6,7,5,4,& +6,9,1,14,5,10,2,13,7,8,0,15,4,11,3,12, 14,13,1,2,9,10,6,5,15,12,0,3,8,11,7,4,& +2,5,1,6,13,10,14,9,3,4,0,7,12,11,15,8, 12,13,15,14,11,10,8,9,3,2,0,1,4,5,7,6,& +13,2,14,1,10,5,9,6,12,3,15,0,11,4,8,7, 9,14,6,1,10,13,5,2,8,15,7,0,11,12,4,3,& +5,6,2,1,10,9,13,14,4,7,3,0,11,8,12,15, 13,14,12,15,10,9,11,8,2,1,3,0,5,6,4,7,& +2,13,5,10,1,14,6,9,3,12,4,11,0,15,7,8, 6,5,9,10,1,2,14,13,7,4,8,11,0,3,15,12,& +14,9,13,10,1,6,2,5,15,8,12,11,0,7,3,4, 8,9,11,10,15,14,12,13,7,6,4,5,0,1,3,2,& +9,6,10,5,14,1,13,2,8,7,11,4,15,0,12,3, 5,2,10,13,6,1,9,14,4,3,11,12,7,0,8,15,& +13,14,10,9,2,1,5,6,12,15,11,8,3,0,4,7, 11,8,10,9,12,15,13,14,4,7,5,6,3,0,2,1,& +5,10,6,9,2,13,1,14,4,11,7,8,3,12,0,15, 13,10,2,5,14,9,1,6,12,11,3,4,15,8,0,7,& +9,10,14,13,6,5,1,2,8,11,15,12,7,4,0,3, 9,10,8,11,14,13,15,12,6,5,7,4,1,2,0,3,& +10,5,13,2,9,6,14,1,11,4,12,3,8,7,15,0, 10,9,5,6,13,14,2,1,11,8,4,7,12,15,3,0,& +10,13,9,14,5,2,6,1,11,12,8,15,4,3,7,0, 10,11,9,8,13,12,14,15,5,4,6,7,2,3,1,0/ + +data presortable/ & + 3,39,40,40,49,61,49,61, 2,22,26,14, 2,22,26,14,& + 3,38,43,62,49,38,49,62, 0, 0,12,12,20,20,24,24,& + 3,38,40,40,51,38,60,60, 1,13, 1,13,25,21,25,21,& + 0, 1,14, 1,23,25,14,25,36,41,62,41,23,49,62,49,& +35, 7,58,46,52,52,58,46, 9, 5, 9, 5,17,29,17,29,& +33, 7,33,47,52,52,56,56,18, 6,10,30,18, 6,10,30,& +33, 7,33,46,57,55,57,46, 4, 4, 8, 8,16,16,28,28,& +10, 5, 4, 4,10,31,16,16,58,45,32,32,58,31,52,52,& +34,54,11,47,34,54,56,56, 9, 5, 9, 5,17,29,17,29,& +35,45,11,45,52,52,56,56,18, 6,10,30,18, 6,10,30,& +34,45,11,45,34,53,59,53, 4, 4, 8, 8,16,16,28,28,& + 8, 8, 9, 6,28,28,19, 6,44,44,33,54,56,56,19,54,& +36,36,43,15,49,61,49,61, 2,22,26,14, 2,22,26,14,& +50,39,42,15,50,61,42,61, 0, 0,12,12,20,20,24,24,& +36,36,42,15,48,48,42,63, 1,13, 1,13,25,21,25,21,& +13, 2,13,12,21, 2,21,27,37,50,37,40,61,50,61,27,& +32,32,58,46,19,55,58,46, 9, 5, 9, 5,17,29,17,29,& +32,32,44,44,19,53,59,53,18, 6,10,30,18, 6,10,30,& +35,45,58,45,19,53,58,53, 4, 4, 8, 8,16,16,28,28,& +11,30, 4, 4,17,30,16,16,11,46,32,32,57,46,52,52,& +41,37,41,37,51,23,60,60, 2,22,26,14, 2,22,26,14,& +50,37,42,37,50,23,42,63, 0, 0,12,12,20,20,24,24,& +50,39,40,40,50,23,60,60, 1,13, 1,13,25,21,25,21,& +13, 3,13,26,21,20,21,26,37, 3,37,42,61,48,61,42,& +41,37,41,37,48,48,27,63, 2,22,26,14, 2,22,26,14,& +41,38,41,62,51,38,27,62, 0, 0,12,12,20,20,24,24,& +36,36,43,62,48,48,27,62, 1,13, 1,13,25,21,25,21,& +22, 1,15, 1,22,25,24,25,38,41,15,41,38,49,60,49,& +34,54,44,44,34,54,59,31, 9, 5, 9, 5,17,29,17,29,& +32,32,44,44,57,55,57,31,18, 6,10,30,18, 6,10,30,& +33,54,33,47,57,54,57,31, 4, 4, 8, 8,16,16,28,28,& + 8, 8,18, 7,28,28,18,29,44,44,34, 7,56,56,34,53,& +33,45,33,45,57,53,57,53,35, 7,10,30,16,16,10,30,& +34,54,58,46,34,54,58,46,35, 5,11, 5,16,16,28,28,& +32,32,44,44,52,52,56,56,35, 5,10, 5,19,29,10,29,& + 9,30, 4, 4,59,30,16,16,33,46,32,32,59,46,52,52,& +50,38,42,62,50,38,42,62, 3,39,12,12,25,21,25,21,& +36,36,40,40,48,48,60,60, 2,39,26,15, 2,21,26,21,& +41,37,41,37,49,61,49,61, 2,39,12,12, 2,23,24,24,& +13, 0,13,26,21,51,21,26,37,36,37,42,61,51,61,42,& +50,38,42,62,50,38,42,62, 0, 0,43,15,25,21,25,21,& +36,36,40,40,48,48,60,60, 3,22,43,14,25,22,25,14,& +41,37,41,37,49,61,49,61, 0, 0,43,14,20,20,27,14,& +22, 1,12, 1,22,25,63,25,38,41,40,41,38,49,63,49,& +33,45,33,45,57,53,57,53,18, 6,11,47,18, 6,28,28,& +34,54,58,46,34,54,58,46, 9, 7, 9,47,16,16,28,28,& +32,32,44,44,52,52,56,56, 9, 6, 9,47,17, 6,17,31,& + 8, 8,18, 5,28,28,18,55,44,44,34,45,56,56,34,55,& +50,38,42,62,50,38,42,62, 1,13, 1,13,51,23,24,24,& +36,36,40,40,48,48,60,60, 1,22, 1,14,51,22,27,14,& +41,37,41,37,49,61,49,61, 3,22,12,12,51,22,24,24,& +39, 1,14, 1,20,25,14,25,39,41,62,41,48,49,62,49,& +33,45,33,45,57,53,57,53, 4, 4,10,30,19,55,10,30,& +34,54,58,46,34,54,58,46, 4, 4, 8, 8,17,55,17,31,& +32,32,44,44,52,52,56,56, 9, 7, 9,30,17,55,17,30,& +10,47, 4, 4,10,29,16,16,58,47,32,32,58,53,52,52,& +33,45,33,45,57,53,57,53,18, 6, 8, 8,18, 6,59,31,& +34,54,58,46,34,54,58,46, 4, 4, 8, 8,19,29,59,29,& +32,32,44,44,52,52,56,56,18, 5,11, 5,18,29,59,29,& + 8, 8,35, 6,28,28,17, 6,44,44,35,54,56,56,57,54,& +50,38,42,62,50,38,42,62, 1,13, 1,13,20,20,27,63,& +36,36,40,40,48,48,60,60, 2,13,26,13, 2,23,26,63,& +41,37,41,37,49,61,49,61, 0, 0,26,15,20,20,26,63,& +13, 2,13,43,21, 2,21,24,37,50,37,43,61,50,61,60/ +!============================================================================= +! At successive refinements, update the present orientation and refine the +! segment on the hilbert curve according to the quadrant of the present +! square occupied by the next generation of refinement's hypercube: +do igen=1,size(hil16) + j=hil16(igen) + hil16(igen)=hil16table (j,presor) + presor =presortable(j,presor) +enddo +end subroutine dig16_to_hil16 + +!============================================================================= +subroutine dig4_to_xy_d(dig,x,y)! [dig4_to_xy] +!============================================================================= +implicit none +integer(i_kind),dimension(:),intent(in ):: dig +real(dp), intent(out):: x,y +!----------------------------------------------------------------------------- +real(dp) :: s +logical,dimension(0:3):: xofd4,yofd4 +integer(i_kind) :: igen,d +data xofd4/F,T,F,T/ +data yofd4/F,F,T,T/ +!============================================================================= +x=u0; y=u0; s=u1 +do igen=size(dig),1,-1 + d=dig(igen); if(xofd4(d))x=x+s; if(yofd4(d))y=y+s + s=s*u2 +enddo +x=x/s; y=y/s +end subroutine dig4_to_xy_d + +!============================================================================= +subroutine dig8_to_xyz_d(dig,x,y,z)! [dig8_to_xyz] +!============================================================================= +implicit none +integer(i_kind),dimension(:),intent(in ):: dig +real(dp), intent(out):: x,y,z +!----------------------------------------------------------------------------- +real(dp) :: s +logical,dimension(0:7):: xofd8,yofd8,zofd8 +integer(i_kind) :: igen,d +data xofd8/F,T,F,T,F,T,F,T/ +data yofd8/F,F,T,T,F,F,T,T/ +data zofd8/F,F,F,F,T,T,T,T/ +!============================================================================= +x=u0; y=u0; z=u0; s=u1 +do igen=size(dig),1,-1 + d=dig(igen); if(xofd8(d))x=x+s; if(yofd8(d))y=y+s; if(zofd8(d))z=z+s + s=s*u2 +enddo +x=x/s; y=y/s; z=z/s +end subroutine dig8_to_xyz_d + +!============================================================================= +subroutine dig16_to_xyza_d(dig,x,y,z,a)! [dig16_to_xyza] +!============================================================================= +implicit none +integer(i_kind),dimension(:),intent(in ):: dig +real(dp), intent(out):: x,y,z,a +!----------------------------------------------------------------------------- +real(dp) :: s +logical,dimension(0:15):: xofd16,yofd16,zofd16,aofd16 +integer(i_kind) :: igen,d +data xofd16/F,T,F,T,F,T,F,T,F,T,F,T,F,T,F,T/ +data yofd16/F,F,T,T,F,F,T,T,F,F,T,T,F,F,T,T/ +data zofd16/F,F,F,F,T,T,T,T,F,F,F,F,T,T,T,T/ +data aofd16/F,F,F,F,F,F,F,F,T,T,T,T,T,T,T,T/ +!============================================================================= +x=u0; y=u0; z=u0; a=u0; s=u1 +do igen=size(dig),1,-1 + d=dig(igen) + if(xofd16(d))x=x+s;if(yofd16(d))y=y+s;if(zofd16(d))z=z+s;if(aofd16(d))a=a+s + s=s*u2 +enddo +x=x/s; y=y/s; z=z/s; a=a/s +end subroutine dig16_to_xyza_d + +!============================================================================= +subroutine xy_to_dig4_s(x,y,dig4)! [xy_to_dig4] +!============================================================================= +! Convert an (x,y)-representation of a point in the square, [0,1]*[0,1] +! to an ngen-digit base-4 number, dig4, where ngen is the size of array dig4. +!============================================================================= +implicit none +real(sp), intent(inout):: x,y +integer(i_kind),dimension(:),intent( out):: dig4 +!----------------------------------------------------------------------------- +integer(i_kind):: igen +!============================================================================= +if(x< 0.0_sp)stop 'In xy_to_dig4; x< 0.0_sp' +if(x> 1.0_sp)stop 'In xy_to_dig4; x> 1.0_sp' +if(y< 0.0_sp)stop 'In xy_to_dig4; y< 0.0_sp' +if(y> 1.0_sp)stop 'In xy_to_dig4; y> 1.0_sp' +dig4=0 +do igen=1,size(dig4) + x=x*2.0_sp; y=y*2.0_sp + if(x>=1.0_sp)then; dig4(igen)=dig4(igen)+1; x=x-1.0_sp; endif + if(y>=1.0_sp)then; dig4(igen)=dig4(igen)+2; y=y-1.0_sp; endif +enddo +end subroutine xy_to_dig4_s +!============================================================================= +subroutine xy_to_dig4_d(x,y,dig4)! [xy_to_dig4] +!============================================================================= +implicit none +real(dp), intent(inout):: x,y +integer(i_kind),dimension(:),intent( out):: dig4 +!----------------------------------------------------------------------------- +integer(i_kind):: igen +!============================================================================= +if(x< u0)stop 'In xy_to_dig4; x< 0.0_dp' +if(x> u1)stop 'In xy_to_dig4; x> 1.0_dp' +if(y< u0)stop 'In xy_to_dig4; y< 0.0_dp' +if(y> u1)stop 'In xy_to_dig4; y> 1.0_dp' +dig4=0 +do igen=1,size(dig4) + x=x*u2; y=y*u2 + if(x>=u1)then; dig4(igen)=dig4(igen)+1; x=x-u1; endif + if(y>=u1)then; dig4(igen)=dig4(igen)+2; y=y-u1; endif +enddo +end subroutine xy_to_dig4_d + +!============================================================================= +subroutine xyz_to_dig8_s(x,y,z,dig8)! [xyz_to_dig8] +!============================================================================= +! Convert an (x,y,z)-representation of a point in the cube, [0,1]*[0,1]*[0,1] +! to an ngen-digit base-8 number, dig8. +!============================================================================= +implicit none +real(sp), intent(inout):: x,y,z +integer(i_kind),dimension(:),intent( out):: dig8 +!----------------------------------------------------------------------------- +integer(i_kind):: igen +!============================================================================= +if(x< 0.0_sp)stop 'In xyz_to_dig8; x< 0.0_sp' +if(x> 1.0_sp)stop 'In xyz_to_dig8; x> 1.0_sp' +if(y< 0.0_sp)stop 'In xyz_to_dig8; y< 0.0_sp' +if(y> 1.0_sp)stop 'In xyz_to_dig8; y> 1.0_sp' +if(z< 0.0_sp)stop 'In xyz_to_dig8; z< 0.0_sp' +if(z> 1.0_sp)stop 'In xyz_to_dig8; z> 1.0_sp' +dig8=0 +do igen=1,size(dig8) + x=x*2.0_sp; y=y*2.0_sp; z=z*2.0_sp + if(x>=1.0_sp)then; dig8(igen)=dig8(igen)+1; x=x-1.0_sp; endif + if(y>=1.0_sp)then; dig8(igen)=dig8(igen)+2; y=y-1.0_sp; endif + if(z>=1.0_sp)then; dig8(igen)=dig8(igen)+4; z=z-1.0_sp; endif +enddo +end subroutine xyz_to_dig8_s +!============================================================================= +subroutine xyz_to_dig8_d(x,y,z,dig8)! [xyz_to_dig8] +!============================================================================= +implicit none +real(dp), intent(inout):: x,y,z +integer(i_kind),dimension(:),intent( out):: dig8 +!----------------------------------------------------------------------------- +integer(i_kind):: igen +!============================================================================= +if(x< u0)stop 'In xyz_to_dig8; x< 0.0_dp' +if(x> u1)stop 'In xyz_to_dig8; x> 1_0_dp' +if(y< u0)stop 'In xyz_to_dig8; y< 0_0_dp' +if(y> u1)stop 'In xyz_to_dig8; y> 1_0_dp' +if(z< u0)stop 'In xyz_to_dig8; z< 0_0_dp' +if(z> u1)stop 'In xyz_to_dig8; z> 1_0_dp' +dig8=0 +do igen=1,size(dig8) + x=x*u2; y=y*u2; z=z*u2 + if(x>=u1)then; dig8(igen)=dig8(igen)+1; x=x-u1; endif + if(y>=u1)then; dig8(igen)=dig8(igen)+2; y=y-u1; endif + if(z>=u1)then; dig8(igen)=dig8(igen)+4; z=z-u1; endif +enddo +end subroutine xyz_to_dig8_d + +!============================================================================= +subroutine xyza_to_dig16_d(x,y,z,a,dig16)! [xyza_to_dig16] +!============================================================================= +! Convert an (x,y,z,t)-representation of a point in the hypercube, +! [0,1]*[0,1]*[0,1]*[0,1] +! to an ngen-digit base-16 number, dig16. +!============================================================================= +implicit none +real(dp), intent(inout):: x,y,z,a +integer(i_kind),dimension(:),intent( out):: dig16 +!----------------------------------------------------------------------------- +integer(i_kind):: igen +!============================================================================= +if(x< u0)stop 'In xyza_to_dig16; x< 0_0_dp' +if(x> u1)stop 'In xyza_to_dig16; x> 1_0_dp' +if(y< u0)stop 'In xyza_to_dig16; y< 0_0_dp' +if(y> u1)stop 'In xyza_to_dig16; y> 1_0_dp' +if(z< u0)stop 'In xyza_to_dig16; z< 0_0_dp' +if(z> u1)stop 'In xyza_to_dig16; z> 1_0_dp' +if(a< u0)stop 'In xyza_to_dig16; a< 0_0_dp' +if(a> u1)stop 'In xyza_to_dig16; a> 1_0_dp' +dig16=0 +do igen=1,size(dig16) + x=x*u2; y=y*u2; z=z*u2; a=a*u2 + if(x>=u1)then; dig16(igen)=dig16(igen)+1; x=x-u1; endif + if(y>=u1)then; dig16(igen)=dig16(igen)+2; y=y-u1; endif + if(z>=u1)then; dig16(igen)=dig16(igen)+4; z=z-u1; endif + if(a>=u1)then; dig16(igen)=dig16(igen)+8; a=a-u1; endif +enddo +end subroutine xyza_to_dig16_d + +!============================================================================= +subroutine gn_to_ea_s(x1,y1, x2,y2)! [gn_to_ea] +!============================================================================= +! Gnomonic to equal-area cubic +!============================================================================= +implicit none +real(sp),intent(IN ):: x1,y1 +real(sp),intent(OUT):: x2,y2 +!----------------------------------------------------------------------------- +integer(i_kind) :: iquad +real(sp) :: x,q,xx,xxp,rxxp,p +!============================================================================= +iquad=1 +if(y1 > x1)iquad=iquad+1 +if(x1 < -y1)iquad=iquad+2 +if(x1== 0.0_sp .and. y1==0.0_sp )then; x2=0.0_sp; y2=0.0_sp; return; endif +select case(iquad) + case(1,4); x=abs(x1); q=y1/x + case(2,3); x=abs(y1); q=x1/x +end select +xx=x*x; xxp=xx+1.0_sp; rxxp=sqrt(xxp) +q=q*sqrt((xx+xxp)/(xxp+q*q*xx)) +p=sqrt(asin(xx/xxp)/pio6) + +select case(iquad) + case(1); x2= p; y2=p*q + case(2); y2= p; x2=p*q + case(3); y2=-p; x2=p*q + case(4); x2=-p; y2=p*q +end select +end subroutine gn_to_ea_s +!============================================================================= +subroutine gn_to_ea_d(x1,y1, x2,y2)! [gn_to_ea] +!============================================================================= +! Gnomonic to equal-area cubic +!============================================================================ +implicit none +real(dp),intent(IN ):: x1,y1 +real(dp),intent(OUT):: x2,y2 +!----------------------------------------------------------------------------- +integer(i_kind) :: iquad +real(dp):: x,q,xx,xxp,rxxp,p +!============================================================================= +iquad=1 +if(y1 > x1)iquad=iquad+1 +if(x1 < -y1)iquad=iquad+2 +if(x1==0.0_dp .and. y1==0.0_dp)then; x2=0.0_dp; y2=0.0_dp; return; endif +select case(iquad) + case(1,4); x=abs(x1); q=y1/x + case(2,3); x=abs(y1); q=x1/x +end select +xx=x*x; xxp=xx+1; rxxp=sqrt(xxp) +q=q*sqrt((xx+xxp)/(xxp+q*q*xx)) +p=sqrt(asin(xx/xxp)/pio6) + +select case(iquad) + case(1); x2= p; y2=p*q + case(2); y2= p; x2=p*q + case(3); y2=-p; x2=p*q + case(4); x2=-p; y2=p*q +end select +end subroutine gn_to_ea_d + + +!============================================================================= +subroutine ea_to_gn_s(x2,y2, x1,y1)! [ea_to_gn] +!============================================================================= +! Equal-area cubic to gnomonic +!============================================================================ +implicit none +real(sp),intent(IN ):: x2,y2 +real(sp),intent(OUT):: x1,y1 +!----------------------------------------------------------------------------- +integer(i_kind) :: iquad +real(sp):: x,q,xx,xxp,p,pp,s +!============================================================================= +iquad=1 +if(y2 > x2)iquad=iquad+1 +if(x2 < -y2)iquad=iquad+2 +if(x2==0.0_sp .and. y2==0.0_sp)then; x1=0.0_sp; y1=0.0_sp; return; endif + +select case(iquad) + case(1); p= x2; q=y2/p + case(2); p= y2; q=x2/p + case(3); p=-y2; q=x2/p + case(4); p=-x2; q=y2/p +end select +pp=p*p +s=sin(pio6*pp) +xx=max(0._sp,s/(1.0_sp-s)) +xxp=xx+1.0_sp +x=sqrt(xx) + +q=q * sqrt( xxp/(xxp+xx*(1.0_sp-q*q)) ) + +select case(iquad) + case(1); x1= x; y1=x*q + case(2); y1= x; x1=x*q + case(3); y1=-x; x1=x*q + case(4); x1=-x; y1=x*q +end select +end subroutine ea_to_gn_s +!============================================================================= +subroutine ea_to_gn_d(x2,y2, x1,y1)! [ea_to_gn] +!============================================================================= +! equal-area cubic to gnomonic +!============================================================================= +implicit none +real(dp),intent(IN ):: x2,y2 +real(dp),intent(OUT):: x1,y1 +!----------------------------------------------------------------------------- +integer(i_kind) :: iquad +real(dp):: x,q,xx,xxp,p,pp,s +!============================================================================= +iquad=1 +if(y2 > x2)iquad=iquad+1 +if(x2 < -y2)iquad=iquad+2 +if(x2==0.0_dp .and. y2==0.0_dp)then; x1=0.0_dp; y1=0.0_dp; return; endif + +select case(iquad) + case(1); p= x2; q=y2/p + case(2); p= y2; q=x2/p + case(3); p=-y2; q=x2/p + case(4); p=-x2; q=y2/p +end select +pp=p*p +s=sin(pio6*pp) +xx=max(u0,s/(1.0_dp-s)) +xxp=xx+u1 +x=sqrt(xx) + +q=q * sqrt( xxp/(xxp+xx*(1.0_dp-q*q)) ) + +select case(iquad) + case(1); x1= x; y1=x*q + case(2); y1= x; x1=x*q + case(3); y1=-x; x1=x*q + case(4); x1=-x; y1=x*q +end select +end subroutine ea_to_gn_d + +!============================================================================= +!============================================================================= +! Routines whose usage is deprecated (better versions are now available) + +!============================================================================= +subroutine hil4_to_rz_s(lgen,ngen,hil4,r)! [hil4_to_rz] +!============================================================================= +! Deprecated; replace by hil4_to_r with r also predefined +implicit none +integer(i_kind), intent(IN ):: lgen,ngen +integer(i_kind),dimension(lgen:ngen),intent(IN ):: hil4 +real(sp), intent(OUT):: r +!----------------------------------------------------------------------------- +real(sp),parameter:: o4=1._sp/4_sp +real(sp) :: p +integer(i_kind) :: i +!============================================================================= +r=0.0_sp; if(lgen==0)r=hil4(lgen) +p=o4 +do i=1,ngen + r=r+p*hil4(i) + p=p*o4 +enddo +end subroutine hil4_to_rz_s +!============================================================================= +subroutine hil4_to_rz_d(lgen,ngen,hil4,r)! [hil4_to_rz] +!============================================================================= +! Deprecated; replace by hil4_to_r with r also predefined +implicit none +integer(i_kind), intent(IN ):: lgen,ngen +integer(i_kind),dimension(lgen:ngen),intent(IN ):: hil4 +real(dp), intent(OUT):: r +!----------------------------------------------------------------------------- +real(dp):: p +integer(i_kind) :: i +!============================================================================= +r=0.0_dp; if(lgen==0)r=hil4(lgen) +p=o4 +do i=1,ngen + r=r+p*hil4(i) + p=p*o4 +enddo +end subroutine hil4_to_rz_d + +!============================================================================= +subroutine hil8_to_rz_d(lgen,ngen,hil8,r)! [hil8_to_rz] +!============================================================================= +! Deprecated; replace by hil8_to_r with r also predefined +implicit none +integer(i_kind), intent(IN ):: lgen,ngen +integer(i_kind),dimension(lgen:ngen),intent(IN ):: hil8 +real(dp), intent(OUT):: r +!----------------------------------------------------------------------------- +real(dp):: p +integer(i_kind) :: i +!============================================================================= +r=0.0_dp; if(lgen==0)r=hil8(lgen) +p=o8 +do i=1,ngen + r=r+p*hil8(i) + p=p*o8 +enddo +end subroutine hil8_to_rz_d + +!============================================================================= +subroutine hil16_to_rz_d(lgen,ngen,hil16,r)! [hil16_to_rz] +!============================================================================= +! Deprecated; replace by hil16_to_r with r also predefined +implicit none +integer(i_kind), intent(IN ):: lgen,ngen +integer(i_kind),dimension(lgen:ngen),intent(IN ):: hil16 +real(dp), intent(OUT):: r +!----------------------------------------------------------------------------- +real(dp):: p +integer(i_kind) :: i +!============================================================================= +r=0.0_dp; if(lgen==0)r=hil16(lgen) +p=o16 +do i=1,ngen + r=r+p*hil16(i) + p=p*o16 +enddo +end subroutine hil16_to_rz_d + +!============================================================================= +subroutine xy_to_hil4z_s(ngen,x,y,hil4)! [xy_to_hil4] +!============================================================================= +! DEPRECATED (since ngen is a redundant variable) +! Convert an (x,y)-representation of a point in the proper interior of the +! unit square to an ngen-digit base-4 representation of the parameter of +! a space-filling Hilbert curve. +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: ngen +real(sp), intent(IN ):: x,y +integer(i_kind),dimension(ngen),intent(OUT):: hil4 +!----------------------------------------------------------------------------- +real(sp):: xr,yr +integer(i_kind) :: presor +!============================================================================= +xr=x; yr=y +call xy_to_dig4(xr,yr,hil4) +presor=0 +call dig4_to_hil4(presor,hil4) +end subroutine xy_to_hil4z_s + +!============================================================================= +subroutine xy_to_hil4z_d(ngen,x,y,hil4)! [xy_to_hil4] +!============================================================================= +! DEPRECATED (since ngen is a redundant variable) +implicit none +integer(i_kind), intent(IN ):: ngen +real(dp), intent(IN ):: x,y +integer(i_kind),dimension(ngen),intent(OUT):: hil4 +!----------------------------------------------------------------------------- +real(dp):: xr,yr +integer(i_kind) :: presor +!============================================================================= +xr=x; yr=y +call xy_to_dig4(xr,yr,hil4) +presor=0 +call dig4_to_hil4(presor,hil4) +end subroutine xy_to_hil4z_d +!============================================================================= +subroutine xyz_to_hil8z_d(ngen,x,y,z,hil8)! [xyz_to_hil8] +!============================================================================= +! DEPRECATED (since ngen is a redundant variable) +implicit none +integer(i_kind), intent(IN ):: ngen +real(dp), intent(IN ):: x,y,z +integer(i_kind),dimension(ngen),intent(OUT):: hil8 +!----------------------------------------------------------------------------- +real(dp):: xr,yr,zr +integer(i_kind) :: presor +!============================================================================= +xr=x; yr=y; zr=z +call xyz_to_dig8(xr,yr,zr,hil8) +presor=0 +call dig8_to_hil8(presor,hil8) +end subroutine xyz_to_hil8z_d + +!============================================================================= +subroutine xyza_to_hil16z_d(ngen,x,y,z,a,hil16)! [xyza_to_hil16] +!============================================================================= +! DEPRECATED (since ngen is a redundant variable) +implicit none +integer(i_kind), intent(IN ):: ngen +real(dp), intent(IN ):: x,y,z,a +integer(i_kind),dimension(ngen),intent(OUT):: hil16 +!----------------------------------------------------------------------------- +real(dp):: xr,yr,zr,ar +integer(i_kind) :: presor +!============================================================================= +xr=x; yr=y; zr=z; ar=a +call xyza_to_dig16(xr,yr,zr,ar,hil16) +presor=0 +call dig16_to_hil16(presor,hil16) +end subroutine xyza_to_hil16z_d + +end module phil0 + diff --git a/src/gsi/phil1.f90 b/src/gsi/phil1.f90 index 815bcf8677..c8de2f3a04 100644 --- a/src/gsi/phil1.f90 +++ b/src/gsi/phil1.f90 @@ -88,7 +88,7 @@ subroutine getvalsets_s(nob, mskip,xhskip,xh,next, firsta,firstb) integer(i_kind), dimension(mskip),intent( OUT) :: firstb !----------------------------------------------------------------------------- integer(i_kind) :: iskip,jskip,this_old_a,this_new_a & - ,icycle,itrial + ,icycle,itrial integer(i_kind), dimension(mskip) :: this_b real(r_kind) :: xhwait,xha real(r_kind),dimension(mskip) :: xhb diff --git a/src/gsi/phil2.f90 b/src/gsi/phil2.f90 new file mode 100644 index 0000000000..9dce41f215 --- /dev/null +++ b/src/gsi/phil2.f90 @@ -0,0 +1,891 @@ +! ************************************** +! * Module phil2 * +! * R. J. Purser NOAA/NCEP/EMC 2017 * +! * jim.purser@noaa.gov * +! ************************************** +! +! Module procedures pertaining to the project, sorting, and density +! estimation by B-spline smoothing the index delta functions of projected +! locations. The particular application that makes this approach potentially +! advantageous compared to conventional alternatives is the estimation +! of the local spatial density of data in those cases where the data tend to be +! inhomogeneously clumped, such as aircraft data, which are typically +! clustered around densely populated areas and along the heavily-trafficked +! flight tracks. +! +! Direct dependencies +! Libraries: psort,pmat +! Modules: phil,psort,peuc,kinds, pietc +! +!============================================================================= +module phil2 +!============================================================================= +! B-spline smoothers of degree 0 and 1 are provided by module procedures +! whose interface names are bsmoo0 and bsmoo1 respectively. The versions +! bsmoo0s and bsmoo1s are special forms that assume that the data locations +! have already been presorted and arranged consecutively; otherwise, the +! versions bsmoo0 and bsmoo1 include an integer index array argument, rank, that +! allows the ordered data to be accessed by indirect addressing. +! The routine, denest, performs such volumetric density estimations in a thin +! spherical shell nrand times and avergaes the results, where nrand can be +! any integerup to 30, or 100, or 300, and uses precomputed pseudo-random +! orientations of the cubic framework within which the hilbert curve is +! constructed over the sphere. The vertical randomization is performed by +! steps that are regular powers of (1/3) times one quarter of the active +! thickness (containing all the data) of the shell. +! The precomputed random rotations are contained in the ascii file, qsets.asc, +! encoded as quaternions. +!============================================================================= +use kinds, only: dp,i_kind +implicit none +private +public:: bsmoo0,bsmoo1,denest,denest2d,& + getqset5,getqset7,getqset8,getqset13 ! <- temporarily public + +interface bsmoo0; module procedure bsmoo0,bsmoo0s; end interface +interface bsmoo1; module procedure bsmoo1,bsmoo1s; end interface +interface denest; module procedure denest,denestx; end interface +interface denest2d; module procedure denest2d,denest2dx; end interface +interface getqset5; module procedure getqset5; end interface +interface getqset7; module procedure getqset7; end interface +interface getqset8; module procedure getqset8; end interface +interface getqset13;module procedure getqset13; end interface + +contains + +!============================================================================= +subroutine bsmoo0(nob,span,sob,rank,dob)! [bsmoo0] +!============================================================================= +! Perform a smoothing of an irregular one-dimensional distribution of nob unit +! impulses at parameter locations, sob, using a boxcar function of total width, +! span. The resulting 'density' at each datum location is dob. Note that this +! is the trivial instance of B-spline smoothing where the degree of the spline +! is zero. +!============================================================================= +implicit none +integer(i_kind), intent(in ):: nob +real(dp), intent(in ):: span +real(dp), dimension(nob),intent(in ):: sob +integer(i_kind) ,dimension(nob),intent(in ):: rank +real(dp), dimension(nob),intent(inout):: dob +!----------------------------------------------------------------------------- +real(dp):: spanh,st,s1,s2 +integer(i_kind) :: i,j,i1,i2,L1,L2 +!============================================================================= +spanh=span/2.0_dp +i1=1 +i2=1 +do i=1,nob + j=rank(i) + st=sob(j); s1=st-spanh; s2=st+spanh + L1=i1; L2=i2 + do i1=l1,nob; if(sob(rank(i1))>s1)exit; enddo + do i2=l2,nob; if(sob(rank(i2))>s2)exit; enddo + dob(j)=dob(j)+(i2-i1)/span +enddo +end subroutine bsmoo0 + +!============================================================================= +subroutine bsmoo0s(nob,span,sob,dob)! [bsmoo0] +!============================================================================= +implicit none +integer(i_kind), intent(in ):: nob +real(dp), intent(in ):: span +real(dp),dimension(nob),intent(in ):: sob +real(dp),dimension(nob),intent(inout):: dob +!----------------------------------------------------------------------------- +real(dp):: spanh,st,s1,s2 +integer(i_kind) :: i,i1,i2,L1,L2 +!============================================================================= +spanh=span/2.0_dp +i1=1 +i2=1 +do i=1,nob + st=sob(i); s1=st-spanh; s2=st+spanh + L1=i1; L2=i2 + do i1=l1,nob; if(sob(i1)>s1)exit; enddo + do i2=l2,nob; if(sob(i2)>s2)exit; enddo + dob(i)=dob(i)+(i2-i1)/span +enddo +end subroutine bsmoo0s + +!============================================================================= +subroutine bsmoo1(nob,span,sob,rank,dob)! [bsmoo1] +!============================================================================= +! Perform a smoothing of an irregular one-dimensional distribution of nob unit +! impulses at parameter locations, sob, using a hat function of half-width, +! span. The resulting 'density' at each datum location is dob. Note that this +! is the instance of a B-spline smoothing where the degree of the spline +! is one. +! +! The general idea of this algorithm is that a piecewise linear spline p(s) +! continuously links nodes at each sb=sob(rank(ib)), +! where the slope changes by +1. +! The distribution of delta functions smoothed by the B-spline of half-width +! span leads to a smooth estimate, dob, at each location, s=sb, given by +! dob(ib) = [p(sb-span) -2*p(sb) +p(sb+span)]/span**2 +! +! However, because this formula, as stated, would tend to involve a "small" +! result coming from differences between approximately equally "large" numbers +! when the count, nob, of data is very large, it is preferable to +! transform the algorithm into a better-conditioned equivalent one in order +! to keep the round-off errors small. We do this by exploiting the fact that +! the result is formally unchanged by adding ANY linear polynomial uniformly +! to the whole spline function, p(s). We choose this polynomial, at each +! stage, to maintain the adjusted spline function p just left of each targetted +! datum, ib, the zero function, and therefore the spline function just right +! of it equal to p(s) = (s-sb), where sb denotes the location of datum ib. +! This keeps the pairs of numerical polynomial coefficients at sa=sb-span and at +! sc=sb+span relatively small. The "slope" coefficient of each linear +! polynomial is always integral, and is therefore not subject to any round-off +! error, but the floating-point constant coefficients, pa0 and pc0, are +! in principle subject to cumulative round-off in cases where the number, nob, +! of data is very large. As a safeguard, we shrink the new pa0 and pc0 values +! towards zero by a very tiny amount at each new datum, but by a degree that +! should be enough to counteract any tendency for cumulative round-off to cause +! their values to spuriously diverge. +!============================================================================= +use pietc, only: u1 +use kinds, only: dp,i_kind +implicit none +integer(i_kind), intent(in ):: nob +real(dp), intent(in ):: span +real(dp), dimension(nob),intent(in ):: sob +integer(i_kind), dimension(nob),intent(in ):: rank +real(dp), dimension(nob),intent(inout):: dob +!----------------------------------------------------------------------------- +real(dp),parameter:: eps=1.0e-13_dp,shrink=1.0_dp-eps +real(dp) :: sa,sb,sc,pa0,pc0,sbold,ds,soba,sobc,spansi +integer(i_kind) :: ia,ib,ic,jb,La,Lc,pa1,pb1,pc1 +!============================================================================= +spansi=u1/span**2 +ia=1 +ic=1 +sbold=0 +! Initially, all the polynomial coefficients vanish: +pa0=0.0_dp +pa1=0 +pb1=0 +pc0=0.0_dp +pc1=0 +do ib=1,nob + jb=rank(ib) + sb=sob(jb); sa=sb-span; sc=sb+span + ds=sb-sbold; sbold=sb +! Move the new coordinate origin to location, sb=sob(rank(ib)) and +! subtract from polynomials A and C the (old) left-polynomial at b: + pa1=pa1-pb1 + pc1=pc1-pb1 + pa0=(pa0+ds*pa1)*shrink ! Shrink by imperceptible amount to stabilize + pc0=(pc0+ds*pc1)*shrink ! huge computations against cumulative round-off +! New pb0 is always taken implicitly to be zero and new pb1 becomes simply: + pb1=1! < (new) rt-polynomial p(s) at B is trivially p=(s-sob(rank(ib))) +! Update the new locations of A and C (straddling B by distance, span) and +! the corresponding polynomial coefficients, {pa0,pa1} and {pc0,pc1} valid +! there: + La=ia; Lc=ic + do ia=La,nob + soba=sob(rank(ia)); if(soba>sa)exit; pa0=pa0+sb-soba; pa1=pa1+1 + enddo + do ic=Lc,nob + sobc=sob(rank(ic)); if(sobc>sc)exit; pc0=pc0+sb-sobc; pc1=pc1+1 + enddo +! The formula, [p(sb-span) -2*p(sb) +p(sb+span)], simplies to: + dob(jb)=dob(jb)+(pa0+pc0+span*(pc1-pa1))*spansi +enddo +end subroutine bsmoo1 +!============================================================================= +subroutine bsmoo1s(nob,span,sob,dob)! [bsmoo1] +!============================================================================= +use pietc, only: u1 +use kinds, only: dp,i_kind +implicit none +integer(i_kind), intent(in ):: nob +real(dp), intent(in ):: span +real(dp),dimension(nob),intent(in ):: sob +real(dp),dimension(nob),intent(inout):: dob +!----------------------------------------------------------------------------- +real(dp),parameter:: eps=1.e-13_dp,shrink=1.0_dp-eps +real(dp) :: sa,sb,sc,pa0,pc0,sbold,ds,spansi +integer(i_kind) :: ia,ib,ic,La,Lc,pa1,pb1,pc1 +!============================================================================= +spansi=u1/span**2 +ia=1 +ic=1 +sbold=0.0_dp +! Initially, all the polynomial coefficients vanish: +pa0=0.0_dp +pa1=0 +pb1=0 +pc0=0.0_dp +pc1=0 +do ib=1,nob + sb=sob(ib); sa=sb-span; sc=sb+span + ds=sb-sbold; sbold=sb +! Move the new coordinate origin to location, sb=sob(ib) and +! subtract from polynomials A and C the (old) left-polynomial at b: + pa1=pa1-pb1 + pc1=pc1-pb1 + pa0=(pa0+ds*pa1)*shrink ! Shrink by imperceptible amount to stabilize + pc0=(pc0+ds*pc1)*shrink ! huge computations against cumulative round-off +! New pb0 is always taken implicitly to be zero and new pb1 becomes simply: + pb1=1! < (new) rt-polynomial p(s) at B is trivially p=(s-sob(ib)) +! Update the new locations of A and C (straddling B by distance, span) and +! the corresponding polynomial coefficients, {pa0,pa1} and {pc0,pc1} valid +! there: + La=ia; Lc=ic + do ia=La,nob; if(sob(ia)>sa)exit; pa0=pa0+sb-sob(ia); pa1=pa1+1; enddo + do ic=Lc,nob; if(sob(ic)>sc)exit; pc0=pc0+sb-sob(ic); pc1=pc1+1; enddo +! The formula, [p(sb-span) -2*p(sb) +p(sb+span)], simplies to: + dob(ib)=dob(ib)+(pa0+pc0+span*(pc1-pa1))*spansi +enddo +end subroutine bsmoo1s + +!============================================================================= +subroutine denest(nob,nrand,nor, &! [denest] + re,dentrip,hscale,vscale,vmin,vmax,& + latob,lonob,altob,wtob) +!============================================================================= +! Use nrand randomized Hilbert curves over a sufficiently thick spherical +! shell to estimate the density of data relative to the "unit" volume +! implied by the vertical smoothing scale time the square of the horizontal +! smoothing scale. +! +! nob: the number of data +! nrand: the number of distinct pseudo-random Hilbert curves +! nor: the order of the B-spline smoother (either 0 or 1) +! re: the nominal radius of the earth +! dentrip:density criterion tripping the downward adjustment to the wt factor +! hscale: (in the same units) the characteristic horizontal scale of averaging +! vscale: (in the same units) the characteristic vertical scale of averaging +! vmin: (in same units) lowest altitude bound for valid data +! vmax: (in same units) greatest altitude bound for valid data +! latob: array of observation latitudes (degrees north) +! lonob: array of observation longitudes (degrees east) +! altob: array of observation altitudes (same units as other distance scales) +! troflg: logic parameter to determin wether dentrip in tropic different from +! other region +! wtob: Weight factor implied by the estimated data density and dentrip +! +! Internally, it is convenient to relate all distance units to "Hilbert +! parameter units" where 24 of these units fill the 24 fundamental +! quadrilateral panels that form the horizontal footprint +! of the spherical shell. This means that one Hilbert unit corresponds to +! a horizontal distance of sqrt(pi/6)*re, or about Uh=4610 km. The thickness, +! in Hilbert distance, of the valid vertical range is +! (vmax-vmin)*hscale/(uh*vscale), which must be less than one for the +! present "thin shell" Hilbert curve construction. We inflate this thickness +! by a small margin to leave room for vertical location randomization of +! the Hilbert curves, and round up to the next integer(i_kind) power, ngen4, of 1/2. +! Ngen4 effectively determines the generation at which the Hilbert curve +! transitions from being 2-dimensional (at coarse scales) to being +! 3-dimensional (at and below the scale of the effective thickness of the +! shell that the curve fills). For generations, 1--ngen4, the expansion is +! at base-4; at ngen4--ngen the expansion is base-8. +!============================================================================= +use pietc, only: u0,u1,u2,o2,pi,dtor +use kinds, only: dp,i_kind +use peuc, only: qtorot,mulqq +use phil0, only: xs_to_hil48,hil8_to_r,hil4_to_r +use psort, only: sort, invertperm +use qcmod, only:troflg,lat_c +implicit none +integer(i_kind), intent(in ):: nob,nrand,nor +real(dp), intent(in ):: re,dentrip,hscale,vscale,vmin,vmax +real(dp),dimension(nob),intent(in ):: latob,lonob,altob +real(dp),dimension(nob),intent(out):: wtob +!----------------------------------------------------------------------------- +integer(i_kind),parameter :: ngen=14 +real(dp), dimension(3,nob) :: xob +real(dp), dimension(nob) :: rob,sob,latobc +real(dp), dimension(0:3) :: qset +real(dp), dimension(0:3,3) :: qset3 +real(dp), dimension(0:3,5) :: qset5 +real(dp), dimension(0:3,7) :: qset7 +real(dp), dimension(0:3,13) :: qset13 +real(dp), dimension(3,3) :: rot,rotnew,rotold +real(dp) :: span,uv,uh,vh,vhq,vhp,v,vrand,& + rlat,clat,slat,rlon,clon,slon +integer(i_kind),dimension(nob) :: rank +integer(i_kind),dimension(0:ngen) :: hilr +integer(i_kind) :: i,irand,j,k,L,ngen4,ntri,dentripc +!============================================================================= +uh=sqrt(pi/6.0_dp)*re +uv=(uh*vscale)/hscale +vh=(vmax-vmin)/uv +vhq=vh/4.0_dp +vhp=vh+vhq +if(vhp>=u1)then + print& + '("In denest; vmax-vmin too large for thin-shell assumption to be valid")' + print'("Make this vertical range smaller, or vscale/hscale larger")' + stop +endif + +v=o2 +do ngen4=0,ngen-1 + if(v=nrand)exit +enddo +vrand=vhq/i +!vrand=3*vhq/i + +! Convert lat and lon to more convenient unit cartesian vectors: +do L=1,nob + rlat=latob(L)*dtor; clat=cos(rlat); slat=sin(rlat) + if(troflg) latobc(L)=latob(L) + rlon=lonob(L)*dtor; clon=cos(rlon); slon=sin(rlon) + xob(:,L)=(/clat*clon,clat*slon,slon/) + rob(L)=(altob(L)-vmin)/uv-vrand! <- altitudes in hilbert vertical units +enddo +if(nrand<1 .or. nrand>273)stop'nrand is invalid' +if(nrand>5)then; call getqset7( qset7); if(nrand>7)call getqset13(qset13) +else; call getqset5(nrand,qset5) +endif +if(nrand>91) call getqset5(3,qset3) + + +! Project the data onto nrand differently-oriented Hilbert curves and sum +! the different estimated density estimates at the ob points in array wtob: +rotnew=u0; do i=1,3; rotnew(i,i)=u1; enddo ! <- Identity matrix. +wtob=0.0_dp +do irand=1,nrand + rotold=rotnew + select case(nrand) + case(1:5) + qset=qset5(:,irand) + case(6:7) + qset=qset7(:,irand) + case(8:13) + qset=qset13(:,irand) + case(14:91) + i=1+mod(irand-1,13) + j=1+(irand-1)/13 + qset=mulqq(qset7(:,j),qset13(:,i)) + case(92:273) + i=1+mod(irand-1,13) + j=1+(irand-1)/13 + k=1+(j-1)/7 + j=1+mod(j-1,7) + qset=mulqq(mulqq(qset13(:,i),qset3(:,k)),qset7(:,j)) + end select + + call qtorot(qset,rotnew) ! convert to an orthogonal matrix +! Form the relative rotation, rot (relative to previous irand iteration): + rot=matmul(rotnew,transpose(rotold)) + +! Get a new fraction of vh/4, based on ternary subdivisions such that the +! binary expansions (in units of vh) are non-terminating. This helps ensure +! that the resulting Hilbert curve projections are not accidentally similar. + do L=1,nob + xob(:,L)=matmul(rot,xob(:,L)) + rob(L) =rob(L)+vrand ! Randomize by new vertical displacement + enddo + do L=1,nob + sob(L)=0_dp + call xs_to_hil48(ngen4,ngen,xob(:,L),rob(L), hilr) + call hil8_to_r(ngen4+1,ngen,hilr(ngen4+1:ngen),sob(L)) + call hil4_to_r(1,ngen4,hilr(1:ngen4),sob(L)) + sob(L)=sob(L)+hilr(0) + enddo! L +! Sort the data implicitly by assigning each a "rank": + call sort(sob,rank); call invertperm(rank) + select case(nor) + case(0) + call bsmoo0(nob,span,sob,rank,wtob) + case(1) + call bsmoo1(nob,span,sob,rank,wtob) + case default + stop'In denest; this value of B-spline order, nor, is not supported' + end select +enddo! irand +! Convert the sum of Hilbert-parameter-relative densities to an average, +! and convert the units of density to number-per-span: +wtob=wtob*span/nrand +do L=1,nob + dentripc=dentrip + if(troflg) then + if(abs(latobc(L)) =u1)then + print& + '("In denest; vmax-vmin too large for thin-shell assumption to be valid")' + print'("Make this vertical range smaller, or vscale/hscale larger")' + stop +endif + +v=o2 +do ngen4=0,ngen-1 + if(v=nrand)exit +enddo +vrand=3.0_dp*vhq/i + +! Convert lat and lon to more convenient unit cartesian vectors: +do L=1,nob + if(troflg) latobc(L)=latob(L) + rlat=latob(L)*dtor; clat=cos(rlat); slat=sin(rlat) + rlon=lonob(L)*dtor; clon=cos(rlon); slon=sin(rlon) + xob(:,L)=(/clat*clon,clat*slon,slon/) + rob(L)=(altob(L)-vmin)/uv-vrand! <- altitudes in hilbert vertical units +enddo +if(nrand<1 .or. nrand>104)stop'nrand is invalid' +if(nrand>5)then; call getqset8( qset8); if(nrand>8)call getqset13(qset13) +else; call getqset5(nrand,qset5) +endif + +! Project the data onto nrand differently-oriented Hilbert curves and sum +! the different estimated density estimates at the ob points in array denob: +rotnew=u0; do i=1,3; rotnew(i,i)=u1; enddo ! <- Identity matrix. +denob=0_dp +do irand=1,nrand + rotold=rotnew + select case(nrand) + case(1:5) + qset=qset5(:,irand) + case(6:8) + qset=qset8(:,irand) + case(9:13) + qset=qset13(:,irand) + case(14:104) + i=1+mod(irand-1,13) + j=1+(irand-1)/13 + qset=mulqq(qset8(:,j),qset13(:,i)) + end select + + call qtorot(qset,rotnew) ! convert to an orthogonal matrix +! Form the relative rotation, rot (relative to previous irand iteration): + rot=matmul(rotnew,transpose(rotold)) + +! Get a new fraction of vh/4, based on ternary subdivisions such that the +! binary expansions (in units of vh) are non-terminating. This helps ensure +! that the resulting Hilbert curve projections are not accidentally similar. + do L=1,nob + xob(:,L)=matmul(rot,xob(:,L)) + rob(L) =rob(L)+vrand ! Randomize by new vertical displacement + enddo + do L=1,nob + sob(L)=0_dp + call xs_to_hil48(ngen4,ngen,xob(:,L),rob(L), hilr) + call hil8_to_r(ngen4+1,ngen,hilr(ngen4+1:ngen),sob(L)) + call hil4_to_r(1,ngen4,hilr(1:ngen4),sob(L)) + sob(L)=sob(L)+hilr(0) + enddo! L +! Sort the data implicitly by assigning each a "rank": + call sort(sob,rank); call invertperm(rank) + select case(nor) + case(0) + call bsmoo0(nob,span,sob,rank,denob) + case(1) + call bsmoo1(nob,span,sob,rank,denob) + case default + stop'In denest; this value of B-spline order, nor, is not supported' + end select +enddo! irand +! Convert the sum of Hilbert-parameter-relative densities to an average, +! and convert the units of density to number-per-span: +denob=denob*span/nrand +do L=1,nob + dentripc=dentrip + if(troflg) then + if(abs(latobc(L)) eps)ff=t + enddo + enddo +endif +end subroutine iinvf + +!============================================================================= +subroutine sldum(a,ipiv,d)! [ldum] +!============================================================================= +implicit none +real(sp), intent(inout) :: a(:,:) +real(sp), intent(out ) :: d +integer(i_kind), intent(out ) :: ipiv(:) +logical :: ff +call sldumf(a,ipiv,d,ff) +if(ff)stop 'In sldum; matrix singular, unable to continue' +end subroutine sldum +!============================================================================= +subroutine dldum(a,ipiv,d)! [ldum] +!============================================================================= +implicit none +real(dp), intent(inout) :: a(:,:) +real(dp), intent(out ) :: d +integer(i_kind), intent(out ) :: ipiv(:) +logical:: ff +call dldumf(a,ipiv,d,ff) +if(ff)stop 'In dldum; matrix singular, unable to continue' +end subroutine dldum +!============================================================================= +subroutine cldum(a,ipiv,d)! [ldum] +!============================================================================= +implicit none +complex(dpc), intent(inout) :: a(:,:) +complex(dpc), intent(out ) :: d +integer(i_kind), intent(out ) :: ipiv(:) +logical:: ff +call cldumf(a,ipiv,d,ff) +if(ff)stop 'In cldum; matrix singular, unable to continue' +end subroutine cldum +!============================================================================= +subroutine sldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +! R.J.Purser, NCEP, Washington D.C. 1996 +! SUBROUTINE LDUM +! perform l-d-u decomposition of square matrix a in place with +! pivoting. +! +! <-> a square matrix to be factorized +! <-- ipiv array encoding the pivoting sequence +! <-- d indicator for possible sign change of determinant +! <-- ff: failure flag, set to .true. when determinant of a vanishes. +!============================================================================= +implicit none +real(SP), intent(INOUT) :: a(:,:) +real(SP), intent(OUT ) :: d +integer(i_kind), intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer(i_kind) :: m,i, j, jp, ibig, jm +real(SP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0.0_sp + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0.0_sp)then + print '("In sldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1.0_sp/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 > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call sswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0.0_sp)then + jm=j-1 + print '(" failure in sldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1.0_sp/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine sldumf +!============================================================================= +subroutine DLDUMf(A,IPIV,D,ff)! [ldum] +!============================================================================= +implicit none +real(DP), intent(INOUT) :: a(:,:) +real(DP), intent(OUT ) :: d +integer(i_kind), intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer(i_kind) :: m,i, j, jp, ibig, jm +real(DP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0.0_dp + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0.0_dp)then + print '("In dldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1.0_dp/aam +enddo +d=1._dp +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 > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call dswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0.0_dp)then + jm=j-1 + print '(" Failure in dldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1.0_dp/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine DLDUMf +!============================================================================= +subroutine cldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +use pietc, only: c0 +implicit none +complex(dpc), intent(INOUT) :: a(:,:) +complex(dpc), intent(OUT ) :: d +integer(i_kind), intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer(i_kind) :: m,i, j, jp, ibig, jm +complex(dpc) :: ajj, ajji, aij +real(dp) :: aam,aa,abig +real(dp),dimension(size(a,1)) :: s +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0.0_dpc + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0.0_dpc)then + print '("In cldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1.0_dpc/aam +enddo +d=1.0_dpc +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 > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call cswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == c0)then + jm=j-1 + print '(" Failure in cldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine cldumf + +!============================================================================= +subroutine sudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMM +! use l-u factors in A to back-substitute for several 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 rt-hand-sides vectors on input, corresponding solutions on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +implicit none +integer(i_kind), dimension(:), intent(in) :: ipiv +real(sp), dimension(:,:),intent(in) :: a +real(sp), dimension(:,:),intent(inout) :: b +integer(i_kind) :: m,i, k, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1,size(b,2) !loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1.0_sp/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine sudlmm +!============================================================================= +subroutine dudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +implicit none +integer(i_kind), dimension(:), intent(in ) :: ipiv +real(dp), dimension(:,:),intent(in ) :: a +real(dp), dimension(:,:),intent(inout) :: b +integer(i_kind) :: m,i, k, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1.0_dp/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine dudlmm +!============================================================================= +subroutine cudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +implicit none +integer(i_kind), dimension(:), intent(in ) :: ipiv +complex(dpc), dimension(:,:),intent(in ) :: a +complex(dpc), dimension(:,:),intent(inout) :: b +integer(i_kind) :: m,i, k, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1.0_dpc/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine cudlmm + +!============================================================================= +subroutine sudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMV +! use l-u factors in A to back-substitute for 1 rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrix +! <-> B right-hand-side vector on input, corresponding solution on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +implicit none +integer(i_kind), dimension(:), intent(in) :: ipiv +real(sp), dimension(:,:),intent(in) :: a +real(sp), dimension(:), intent(inout) :: b +integer(i_kind) :: m,i, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1.0_sp/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine sudlmv +!============================================================================= +subroutine dudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +implicit none +integer(i_kind), dimension(:), intent(in ) :: ipiv(:) +real(dp), dimension(:,:),intent(in ) :: a(:,:) +real(dp), dimension(:), intent(inout) :: b(:) +integer(i_kind) :: m,i, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1.0_dp/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine dudlmv +!============================================================================= +subroutine cudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +implicit none +integer(i_kind), dimension(:), intent(in ) :: ipiv(:) +complex(dpc), dimension(:,:),intent(in ) :: a(:,:) +complex(dpc), dimension(:), intent(inout) :: b(:) +integer(i_kind) :: m,i, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1.0_dpc/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine cudlmv + +!============================================================================= +subroutine sl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +implicit none +real(sp), intent(in ) :: a(:,:) +real(sp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call sl1lmf(a,b,ff) +if(ff)stop 'In sl1lm; matrix singular, unable to continue' +end subroutine sl1lm +!============================================================================= +subroutine dl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +implicit none +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call dl1lmf(a,b,ff) +if(ff)stop 'In dl1lm; matrix singular, unable to continue' +end subroutine dl1lm + +!============================================================================= +subroutine sl1lmf(a,b,ff)! [L1Lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +implicit none +real(sp), intent(IN ) :: a(:,:) +real(sp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer(i_kind) :: m,j, jm, jp, i +real(sp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(S <= 0_sp) + if(ff)then + print '("sL1Lmf detects nonpositive a, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1.0_sp/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0.0_sp +enddo +end subroutine sl1lmf +!============================================================================= +subroutine dl1lmf(a,b,ff) ! [L1Lm] +!============================================================================= +implicit none +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer(i_kind) :: m,j, jm, jp, i +real(dp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(s <= 0.0_dp) + if(ff)then + print '("dL1LMF detects nonpositive A, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1.0_dp/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0.0_dp +enddo +return +end subroutine dl1lmf + +!============================================================================= +subroutine sldlm(a,b,d)! [LdLm] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +implicit none +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call sldlmf(a,b,d,ff) +if(ff)stop 'In sldlm; matrix singular, unable to continue' +end subroutine sldlm +!============================================================================= +subroutine dldlm(a,b,d)! [LdLm] +!============================================================================= +implicit none +real(dp), intent(IN ):: a(:,:) +real(dp), intent(INOUT):: b(:,:) +real(dp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call dldlmf(a,b,d,ff) +if(ff)stop 'In dldlm; matrix singular, unable to continue' +end subroutine dldlm + +!============================================================================= +subroutine sldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U +!============================================================================= +implicit none +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +integer(i_kind) :: m,j, jm, jp, i +real(sp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1.0_sp + ff=(d(j) == 0.0_sp) + if(ff)then + print '("In sldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=1.0_sp/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0.0_sp +enddo +end subroutine sldlmf +!============================================================================= +subroutine dldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +implicit none +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +real(dp), intent( OUT) :: d(:) +logical, intent( OUT) :: ff +!----------------------------------------------------------------------------- +integer(i_kind) :: m,j, jm, jp, i +real(dp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m; jm=j-1; jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1.0_dp + ff=(d(j) == 0.0_dp) + if(ff)then + print '("In dldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=1.0_dp/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0.0_dp +enddo +end subroutine dldlmf + +!============================================================================== +subroutine sinvu(a)! [invu] +!============================================================================== +! Invert the upper triangular matrix in place by transposing, calling +! invl, and transposing again. +!============================================================================== +implicit none +real,dimension(:,:),intent(inout):: a +a=transpose(a); call sinvl(a); a=transpose(a) +end subroutine sinvu +!============================================================================== +subroutine dinvu(a)! [invu] +!============================================================================== +implicit none +real(dp),dimension(:,:),intent(inout):: a +a=transpose(a); call dinvl(a); a=transpose(a) +end subroutine dinvu +!============================================================================== +subroutine sinvl(a)! [invl] +!============================================================================== +! Invert lower triangular matrix in place +!============================================================================== +implicit none +real(sp), intent(inout) :: a(:,:) +integer(i_kind) :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0_sp + a(j,j)=1._sp/a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine sinvl +!============================================================================== +subroutine dinvl(a)! [invl] +!============================================================================== +implicit none +real(dp), intent(inout) :: a(:,:) +integer(i_kind) :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0_dp + a(j,j)=1._dp/a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine dinvl + +!============================================================================== +subroutine slinlv(a,u)! [invl] +!============================================================================== +! Solve linear system involving lower triangular system matrix. +!============================================================================== +implicit none +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer(i_kind) :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In slinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine slinlv +!============================================================================== +subroutine dlinlv(a,u)! [invl] +!============================================================================== +implicit none +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer(i_kind) :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine dlinlv + +!============================================================================== +subroutine slinuv(a,u)! [invu] +!============================================================================== +! Solve linear system involving upper triangular system matrix. +!============================================================================== +implicit none +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer(i_kind) :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In linuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine slinuv +!============================================================================== +subroutine dlinuv(a,u)! [invu] +!============================================================================== +implicit none +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer(i_kind) :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine dlinuv + +end module pmat + diff --git a/src/gsi/pmat4.f90 b/src/gsi/pmat4.f90 new file mode 100644 index 0000000000..71c9074d70 --- /dev/null +++ b/src/gsi/pmat4.f90 @@ -0,0 +1,1854 @@ +! +! ********************************************** +! * MODULE peuc * +! * R. J. Purser, NOAA/NCEP/EMC Oct 2005 * +! * 18th May 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! Euclidean geometry, geometric (stereographic) projections, +! related transformations (Mobius). +! Package for handy vector and matrix operations in Euclidean geometry. +! This package is primarily intended for 3D operations and three of the +! functions (Cross_product, Triple_product and Axial) do not possess simple +! generalizations to a generic number N of dimensions. The others, while +! admitting such N-dimensional generalizations, have not all been provided +! with such generic forms here at the time of writing, though some of these +! may be added at a future date. +! +! May 2017: Added routines to facilitate manipulation of 3D rotations, +! their representations by axial vectors, and routines to compute the +! exponentials of matrices (without resort to eigen methods). Also added +! Quaternion and spinor representations of 3D rotations, and their +! conversion routines. +! +! FUNCTION: +! absv: Absolute magnitude of vector as its euclidean length +! Normalized: Normalized version of given real vector +! Orthogonalized: Orthogonalized version of second vector rel. to first unit v. +! Cross_product: Vector cross-product of the given 2 vectors +! Outer_product: outer-product matrix of the given 2 vectors +! Triple_product: Scalar triple product of given 3 vectors +! Det: Determinant of given matrix +! Axial: Convert axial-vector <--> 2-form (antisymmetric matrix) +! Diag: Diagnl of given matrix, or diagonal matrix of given elements +! Trace: Trace of given matrix +! Identity: Identity 3*3 matrix, or identity n*n matrix for a given n +! Sarea: Spherical area subtended by three vectors +! Huarea: Spherical area subtended by right-angled spherical triangle +! SUBROUTINE: +! Gram: Right-handed orthogonal basis and rank, nrank. The first +! nrank basis vectors span the column range of matrix given, +! OR ("plain" version) simple unpivoted Gram-Schmidt of a +! square matrix. +! +! In addition, we include routines that relate to stereographic projections +! and some associated mobius transformation utilities, since these complex +! operations have a strong geometrical flavor. +! +! DIRECT DEPENDENCIES +! Libraries[their Modules]: pmat[pmat] +! Additional Modules : kinds, pietc +! +!============================================================================ +module peuc +!============================================================================ +use kinds, only: sp,dp,dpc,i_kind +implicit none +private +public:: absv,normalized,orthogonalized, & + cross_product,outer_product,triple_product,det,axial, & + diag,trace,identity,sarea,huarea, & + normalize,gram,rowops,corral, & + axtoq,qtoax, & + rottoax,axtorot,spintoq,qtospin,rottoq,qtorot,mulqq, & + expmat,zntay,znfun, & + ctoz,ztoc,setmobius, & + mobius,mobiusi + +interface absv; module procedure absv_s,absv_d; end interface +interface normalized;module procedure normalized_s,normalized_d;end interface +interface orthogonalized + module procedure orthogonalized_s,orthogonalized_d; end interface +interface cross_product + module procedure cross_product_s,cross_product_d; end interface +interface outer_product + module procedure outer_product_s,outer_product_d,outer_product_i + end interface +interface triple_product + module procedure triple_product_s,triple_product_d; end interface +interface det; module procedure det_s,det_d,det_i,det_id; end interface +interface axial + module procedure axial3_s,axial3_d,axial33_s,axial33_d; end interface +interface diag + module procedure diagn_s,diagn_d,diagn_i,diagnn_s,diagnn_d,diagnn_i + end interface +interface trace; module procedure trace_s,trace_d,trace_i; end interface +interface identity; module procedure identity_i,identity3_i; end interface +interface huarea; module procedure huarea_s,huarea_d; end interface +interface sarea; module procedure sarea_s,sarea_d; end interface +interface normalize;module procedure normalize_s,normalize_d; end interface +interface gram + module procedure gram_s,gram_d,graml_d,plaingram_s,plaingram_d,rowgram + end interface +interface rowops; module procedure rowops; end interface +interface corral; module procedure corral; end interface +interface rottoax; module procedure rottoax; end interface +interface axtorot; module procedure axtorot; end interface +interface spintoq; module procedure spintoq; end interface +interface qtospin; module procedure qtospin; end interface +interface rottoq; module procedure rottoq; end interface +interface qtorot; module procedure qtorot; end interface +interface axtoq; module procedure axtoq; end interface +interface qtoax; module procedure qtoax; end interface +interface setem; module procedure setem; end interface +interface mulqq; module procedure mulqq; end interface +interface expmat; module procedure expmat,expmatd,expmatdd; end interface +interface zntay; module procedure zntay; end interface +interface znfun; module procedure znfun; end interface +interface ctoz; module procedure ctoz; end interface +interface ztoc; module procedure ztoc,ztocd; end interface +interface setmobius;module procedure setmobius,zsetmobius; end interface +interface mobius; module procedure zmobius,cmobius; end interface +interface mobiusi; module procedure zmobiusi; end interface + +contains + +!============================================================================= +function absv_s(a)result(s)! [absv] +!============================================================================= +implicit none + +real(sp),dimension(:),intent(in):: a +real(sp) :: s +s=sqrt(dot_product(a,a)) +end function absv_s +!============================================================================= +function absv_d(a)result(s)! [absv] +!============================================================================= +implicit none +real(dp),dimension(:),intent(in):: a +real(dp) :: s +s=sqrt(dot_product(a,a)) +end function absv_d + +!============================================================================= +function normalized_s(a)result(b)! [normalized] +!============================================================================= +implicit none +real(sp),dimension(:),intent(IN):: a +real(sp),dimension(size(a)) :: b +real(sp) :: s +s=absv_s(a); if(s==0_dp)then; b=0_dp;else;b=a/s;endif +end function normalized_s +!============================================================================= +function normalized_d(a)result(b)! [normalized] +!============================================================================= +implicit none +real(dp),dimension(:),intent(IN):: a +real(dp),dimension(size(a)) :: b +real(dp) :: s +s=absv_d(a); if(s==0_dp)then; b=0_dp;else;b=a/s;endif +end function normalized_d + +!============================================================================= +function orthogonalized_s(u,a)result(b)! [orthogonalized] +!============================================================================= +implicit none +real(sp),dimension(:),intent(in):: u,a +real(sp),dimension(size(u)) :: b +real(sp) :: s +! Note: this routine assumes u is already normalized +s=dot_product(u,a); b=a-u*s +end function orthogonalized_s +!============================================================================= +function orthogonalized_d(u,a)result(b)! [orthogonalized] +!============================================================================= +implicit none +real(dp),dimension(:),intent(in):: u,a +real(dp),dimension(size(u)) :: b +real(dp) :: s +! Note: this routine assumes u is already normalized +s=dot_product(u,a); b=a-u*s +end function orthogonalized_d + +!============================================================================= +function cross_product_s(a,b)result(c)! [cross_product] +!============================================================================= +implicit none +real(sp),dimension(3),intent(in):: a,b +real(sp),dimension(3) :: c +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) +end function cross_product_s +!============================================================================= +function cross_product_d(a,b)result(c)! [cross_product] +!============================================================================= +implicit none +real(dp),dimension(3),intent(in):: a,b +real(dp),dimension(3) :: c +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) +end function cross_product_d + +!============================================================================= +function outer_product_s(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +real(sp),dimension(:), intent(in ):: a +real(sp),dimension(:), intent(in ):: b +real(sp),DIMENSION(size(a),size(b)):: c +integer(i_kind) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_s +!============================================================================= +function outer_product_d(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +real(dp),dimension(:), intent(in ):: a +real(dp),dimension(:), intent(in ):: b +real(dp),dimension(size(a),size(b)):: c +integer(i_kind) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_d +!============================================================================= +function outer_product_i(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +integer(i_kind),dimension(:), intent(in ):: a +integer(i_kind),dimension(:), intent(in ):: b +integer(i_kind),dimension(size(a),size(b)):: c +integer(i_kind) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_i + +!============================================================================= +function triple_product_s(a,b,c)result(tripleproduct)! [triple_product] +!============================================================================= +implicit none +real(sp),dimension(3),intent(IN ):: a,b,c +real(sp) :: tripleproduct +tripleproduct=dot_product( cross_product(a,b),c ) +end function triple_product_s +!============================================================================= +function triple_product_d(a,b,c)result(tripleproduct)! [triple_product] +!============================================================================= +implicit none +real(dp),dimension(3),intent(IN ):: a,b,c +real(dp) :: tripleproduct +tripleproduct=dot_product( cross_product(a,b),c ) +end function triple_product_d + +!============================================================================= +function det_s(a)result(det)! [det] +!============================================================================= +implicit none +real(sp),dimension(:,:),intent(IN ) ::a +real(sp) :: det +real(sp),dimension(size(a,1),size(a,1)):: b +integer(i_kind) :: n,nrank +n=size(a,1) +if(n==3)then + det=triple_product(a(:,1),a(:,2),a(:,3)) +else + call gram(a,b,nrank,det) + if(nranknrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)<0_sp)s=-s + det=det*s + b(:,k)=b(:,k)/s + do l=k,n + do j=l+1,n + s=dot_product(b(:,l),b(:,j)) + b(:,j)=normalized( b(:,j)-b(:,l)*s ) + enddo + enddo +enddo +end subroutine gram_s + +!============================================================================= +subroutine gram_d(as,b,nrank,det)! [gram] +!============================================================================= +implicit none +real(dp),dimension(:,:),intent(IN ) :: as +real(dp),dimension(:,:),intent(OUT) :: b +integer(i_kind), intent(OUT) :: nrank +real(dp), intent(OUT) :: det +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter :: crit=1.e-9_dp +real(dp),dimension(size(as,1),size(as,2)):: a +real(dp),dimension(size(as,2),size(as,1)):: ab +real(dp),dimension(size(as,1)) :: tv,w +real(dp) :: val,s,vcrit +integer(i_kind) :: i,j,k,l,m,n +integer(i_kind),dimension(2) :: ii +!============================================================================= +n=size(as,1) +m=size(as,2) +if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions' +a=as +b=identity(n) +det=1_dp +val=maxval(abs(a)) +if(val==0_dp)then + nrank=0 + return +endif +vcrit=val*crit +nrank=min(n,m) +do k=1,n + if(k>nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)<0_dp)s=-s + det=det*s + b(:,k)=b(:,k)/s + do l=k,n + do j=l+1,n + s=dot_product(b(:,l),b(:,j)) + b(:,j)=normalized( b(:,j)-b(:,l)*s ) + enddo + enddo +enddo +end subroutine gram_d + +!============================================================================= +subroutine graml_d(as,b,nrank,detsign,ldet)! [gram] +!============================================================================= +! A version of gram_d where the determinant information is returned in +! logarithmic form (to avoid overflows for large matrices). When the +! matrix is singular, the "sign" of the determinant, detsign, is returned +! as zero (instead of either +1 or -1) and ldet is then just the log of +! the nonzero factors found by the process. +!============================================================================= +implicit none +real(dp),dimension(:,:),intent(IN ) :: as +real(dp),dimension(:,:),intent(OUT) :: b +integer(i_kind), intent(OUT) :: nrank +integer(i_kind), intent(out) :: detsign +real(dp), intent(OUT) :: ldet +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter :: crit=1.e-9_dp +real(dp),dimension(size(as,1),size(as,2)):: a +real(dp),dimension(size(as,2),size(as,1)):: ab +real(dp),dimension(size(as,1)) :: tv,w +real(dp) :: val,s,vcrit +integer(i_kind) :: i,j,k,l,m,n +integer(i_kind),dimension(2) :: ii +!============================================================================= +detsign=1_dp +n=size(as,1) +m=size(as,2) +if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions' +a=as +b=identity(n) +!det=1 +ldet=0_dp +val=maxval(abs(a)) +if(val==0_dp)then + nrank=0 + return +endif +vcrit=val*crit +nrank=min(n,m) +do k=1,n + if(k>nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)<0_dp)s=-s + if(s<0_dp)then + ldet=ldet+log(-s) + detsign=-detsign + elseif(s>0_dp)then + ldet=ldet+log(s) + else + detsign=0 + endif + +! det=det*s + b(:,k)=b(:,k)/s + do l=k,n + do j=l+1,n + s=dot_product(b(:,l),b(:,j)) + b(:,j)=normalized( b(:,j)-b(:,l)*s ) + enddo + enddo +enddo +end subroutine graml_d + +!============================================================================= +subroutine plaingram_s(b,nrank)! [gram] +!============================================================================= +! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only. +implicit none +real(sp),dimension(:,:),intent(INOUT) :: b +integer(i_kind), intent( OUT) :: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(sp),parameter :: crit=1.e-5_sp +real(sp) :: val,vcrit +integer(i_kind) :: j,k,n +!============================================================================= +n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square' +val=maxval(abs(b)) +nrank=0 +if(val==0_sp)then + b=0_sp + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=0_sp + return + endif + b(:,k)=b(:,k)/val + nrank=k + do j=k+1,n + b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j)) + enddo +enddo +end subroutine plaingram_s + +!============================================================================= +subroutine plaingram_d(b,nrank)! [gram] +!============================================================================= +! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only. +implicit none +real(dp),dimension(:,:),intent(INOUT) :: b +integer(i_kind), intent( OUT) :: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter :: crit=1.e-9_dp +real(dp) :: val,vcrit +integer(i_kind) :: j,k,n +!============================================================================= +n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square' +val=maxval(abs(b)) +nrank=0 +if(val==0_dp)then + b=0_dp + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=0_dp + return + endif + b(:,k)=b(:,k)/val + nrank=k + do j=k+1,n + b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j)) + enddo +enddo +end subroutine plaingram_d + +!============================================================================= +subroutine rowgram(m,n,a,ipiv,tt,b,rank)! [gram] +!============================================================================= +! Without changing (tall) rectangular input matrix a, perform pivoted gram- +! schmidt operations to orthogonalize the rows, until rows that remain become +! negligible. Record the pivoting sequence in ipiv, and the row-normalization +! in tt(j,j) and the row-orthogonalization in tt(i,j), for i>j. Note that +! tt(i,j)=0 for i=n please' +nepss=n*epss +rank=n +aa=a +tt=0_dp +do ii=1,n + +! At this stage, all rows less than ii are already orthonormalized and are +! orthogonal to all rows at and beyond ii. Find the norms of these lower +! rows and pivot the largest of them into position ii: + maxp=0_dp + maxi=ii + do i=ii,m + p(i)=dot_product(aa(i,:),aa(i,:)) + if(p(i)>maxp)then + maxp=p(i) + maxi=i + endif + enddo + if(maxpu1(2))then + j=3 +else + j=2 +endif +ss=u1(j) +if(ss==0_dp)stop 'In rotov; invalid rot' +if(j/=2)t1(2,:)=t1(3,:) +t1(2,:)=t1(2,:)/sqrt(ss) + +! Form t1(3,:) as the cross product of t1(1,:) and t1(2,:) +t1(3,1)=t1(1,2)*t1(2,3)-t1(1,3)*t1(2,2) +t1(3,2)=t1(1,3)*t1(2,1)-t1(1,1)*t1(2,3) +t1(3,3)=t1(1,1)*t1(2,2)-t1(1,2)*t1(2,1) + +! Project rot into the frame whose axes are the rows of t1: +t2=matmul(t1,matmul(rot,transpose(t1))) + +! Obtain the rotation angle, gamma, implied by rot, and gammah=gamma/2: +gamma=atan2(t2(2,1),t2(1,1)); gammah=gamma/2_dp + +! Hence deduce coefficients (in the form of a real 4-vector) of one of the two +! possible equivalent spinors: +s=sin(gammah) +q(0)=cos(gammah) +q(1:3)=t1(3,:)*s +end subroutine rottoq + +!============================================================================== +subroutine qtorot(q,rot)! [qtorot] +!============================================================================== +! Go from quaternion to rotation matrix representations +!============================================================================== +implicit none +real(dp),dimension(0:3),intent(IN ):: q +real(dp),dimension(3,3),intent(OUT):: rot +!============================================================================= +call setem(q(0),q(1),q(2),q(3),rot) +end subroutine qtorot + +!============================================================================= +subroutine axtoq(v,q)! [axtoq] +!============================================================================= +! Go from an axial 3-vector to its equivalent quaternion +!============================================================================= +implicit none +real(dp),dimension(3), intent(in ):: v +real(dp),dimension(0:3),intent(out):: q +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: rot +!============================================================================= +call axtorot(v,rot) +call rottoq(rot,q) +end subroutine axtoq + +!============================================================================= +subroutine qtoax(q,v)! [qtoax] +!============================================================================= +! Go from quaternion to axial 3-vector +!============================================================================= +implicit none +real(dp),dimension(0:3),intent(in ):: q +real(dp),dimension(3), intent(out):: v +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: rot +!============================================================================= +call qtorot(q,rot) +call rottoax(rot,v) +end subroutine qtoax + +!============================================================================= +subroutine setem(c,d,e,g,r)! [setem] +!============================================================================= +implicit none +real(dp), intent(IN ):: c,d,e,g +real(dp),dimension(3,3),intent(OUT):: r +!----------------------------------------------------------------------------- +real(dp):: cc,dd,ee,gg,de,dg,eg,dc,ec,gc +!============================================================================= +cc=c*c; dd=d*d; ee=e*e; gg=g*g +de=d*e; dg=d*g; eg=e*g +dc=d*c; ec=e*c; gc=g*c +r(1,1)=cc+dd-ee-gg; r(2,2)=cc-dd+ee-gg; r(3,3)=cc-dd-ee+gg +r(2,3)=2_dp*(eg-dc); r(3,1)=2_dp*(dg-ec); r(1,2)=2_dp*(de-gc) +r(3,2)=2_dp*(eg+dc); r(1,3)=2_dp*(dg+ec); r(2,1)=2_dp*(de+gc) +end subroutine setem + +!============================================================================= +function mulqq(a,b)result(c)! [mulqq] +!============================================================================= +! Multiply quaternions, a*b, assuming operation performed from right to left +!============================================================================= +implicit none +real(dp),dimension(0:3),intent(IN ):: a,b +real(dp),dimension(0:3) :: c +!------------------------------------------- +c(0)=a(0)*b(0) -a(1)*b(1) -a(2)*b(2) -a(3)*b(3) +c(1)=a(0)*b(1) +a(1)*b(0) +a(2)*b(3) -a(3)*b(2) +c(2)=a(0)*b(2) +a(2)*b(0) +a(3)*b(1) -a(1)*b(3) +c(3)=a(0)*b(3) +a(3)*b(0) +a(1)*b(2) -a(2)*b(1) +end function mulqq +!============================================================================= +subroutine expmat(n,a,b,detb)! [expmat] +!============================================================================= +! Evaluate the exponential, b, of a matrix, a, of degree n. +! Apply the iterated squaring method, m times, to the approximation to +! exp(a/(2**m)) obtained as a Taylor expansion of degree L +! See Fung, T. C., 2004, Int. J. Numer. Meth. Engng, 59, 1273--1286. +!============================================================================= +use pietc, only: u1,u2,o2 +implicit none +integer(i_kind), intent(IN ):: n +real(dp),dimension(n,n),intent(IN ):: a +real(dp),dimension(n,n),intent(OUT):: b +real(dp), intent(OUT):: detb +!----------------------------------------------------------------------------- +integer(i_kind),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp) :: t +integer(i_kind) :: i,m +!============================================================================= +m=10+log(u1+maxval(abs(a)))/log(u2) +t=o2**m +c=a*t +p=c +b=p +do i=2,L + p=matmul(p,c)/i + b=b+p +enddo +do i=1,m + b=b*2_dp+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+1_dp +enddo +detb=0_dp; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +end subroutine expmat + +!============================================================================= +subroutine expmatd(n,a,b,bd,detb,detbd)! [expmat] +!============================================================================= +! Like expmat, but for the 1st derivatives also. +!============================================================================= +use pietc, only: u1,u2,o2 +implicit none +integer(i_kind), intent(IN ):: n +real(dp),dimension(n,n), intent(IN ):: a +real(dp),dimension(n,n), intent(OUT):: b +real(dp),dimension(n,n,(n*(n+1))/2),intent(OUT):: bd +real(dp), intent(OUT):: detb +real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd +!----------------------------------------------------------------------------- +integer(i_kind),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp),dimension(n,n,(n*(n+1))/2):: pd,cd +real(dp) :: t +integer(i_kind) :: i,j,k,m,n1 +!============================================================================= +n1=(n*(n+1))/2 +m=10+log(u1+maxval(abs(a)))/log(u2) +t=o2**m +c=a*t +p=c +pd=0_dp +do k=1,n + pd(k,k,k)=t +enddo +k=n +do i=1,n-1 + do j=i+1,n + k=k+1 + pd(i,j,k)=t + pd(j,i,k)=t + enddo +enddo +if(k/=n1)stop 'In expmatd; n1 is inconsistent with n' +cd=pd +b=p +bd=pd + +do i=2,L + do k=1,n1 + pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i + enddo + p=matmul(c,p)/i + b=b+p + bd=bd+pd +enddo +do i=1,m + do k=1,n1 + bd(:,:,k)=2_dp*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k)) + enddo + b=b*2_dp+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+1_dp +enddo +detb=0_dp; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=0_dp; do k=1,n; detbd(k)=detb; enddo +end subroutine expmatd + +!============================================================================= +subroutine expmatdd(n,a,b,bd,bdd,detb,detbd,detbdd)! [expmat] +!============================================================================= +! Like expmat, but for the 1st and 2nd derivatives also. +!============================================================================= +use pietc, only: u1,u2,o2 +implicit none +integer(i_kind), intent(IN ):: n +real(dp),dimension(n,n), intent(IN ):: a +real(dp),dimension(n,n), intent(OUT):: b +real(dp),dimension(n,n,(n*(n+1))/2), intent(OUT):: bd +real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2),intent(OUT):: bdd +real(dp), intent(OUT):: detb +real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd +real(dp),dimension((n*(n+1))/2,(n*(n+1))/2), intent(OUT):: detbdd +!----------------------------------------------------------------------------- +integer(i_kind),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp),dimension(n,n,(n*(n+1))/2) :: pd,cd +real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2):: pdd,cdd +real(dp) :: t +integer(i_kind) :: i,j,k,ki,kj,m,n1 +!============================================================================= +n1=(n*(n+1))/2 +m=10+log(u1+maxval(abs(a)))/log(u2) +t=o2**m +c=a*t +p=c +pd=0_dp +pdd=0_dp +do k=1,n + pd(k,k,k)=t +enddo +k=n +do i=1,n-1 + do j=i+1,n + k=k+1 + pd(i,j,k)=t + pd(j,i,k)=t + enddo +enddo +if(k/=n1)stop 'In expmatd; n1 is inconsistent with n' +cd=pd +cdd=0_dp +b=p +bd=pd +bdd=0_dp + +do i=2,L + do ki=1,n1 + do kj=1,n1 + pdd(:,:,ki,kj)=(matmul(cd(:,:,ki),pd(:,:,kj)) & + + matmul(cd(:,:,kj),pd(:,:,ki)) & + + matmul(c,pdd(:,:,ki,kj)))/i + enddo + enddo + do k=1,n1 + pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i + enddo + p=matmul(c,p)/i + b=b+p + bd=bd+pd + bdd=bdd+pdd +enddo +do i=1,m + do ki=1,n1 + do kj=1,n1 + bdd(:,:,ki,kj)=2_dp*bdd(:,:,ki,kj) & + +matmul(bdd(:,:,ki,kj),b) & + +matmul(bd(:,:,ki),bd(:,:,kj)) & + +matmul(bd(:,:,kj),bd(:,:,ki)) & + +matmul(b,bdd(:,:,ki,kj)) + enddo + enddo + do k=1,n1 + bd(:,:,k)=2_dp*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k)) + enddo + b=b*2_dp+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+1_dp +enddo +detb=0_dp; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=0_dp; do k=1,n; detbd(k)=detb; enddo +detbdd=0_dp; do ki=1,n; do kj=1,n; detbdd(ki,kj)=detb; enddo; enddo +end subroutine expmatdd + +!============================================================================= +subroutine zntay(n,z,zn)! [zntay] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: n +real(dp),intent(IN ):: z +real(dp),intent(OUT):: zn +!----------------------------------------------------------------------------- +integer(i_kind),parameter :: ni=100 +real(dp),parameter :: eps0=1.e-16_dp +integer(i_kind) :: i,i2,n2 +real(dp) :: t,eps,z2 +!============================================================================= +z2=z*2 +n2=n*2 +t=1_dp +do i=1,n + t=t/(i*2_dp-1_dp) +enddo +eps=t*eps0 +zn=t +t=t +do i=1,ni + i2=i*2 + t=t*z2/(i2*(i2+n2-1_dp)) + zn=zn+t + if(abs(t)0_dp)then + zn=cosh(rz2) + znd=sinh(rz2)/rz2 + zndd=(zn-znd)/z2 + znddd=(znd-3_dp*zndd)/z2 + do i=1,n + i2p3=i*2+3 + zn=znd + znd=zndd + zndd=znddd + znddd=(znd-i2p3*zndd)/z2 + enddo + else + zn=cos(rz2) + znd=sin(rz2)/rz2 + zndd=-(zn-znd)/z2 + znddd=-(znd-3_dp*zndd)/z2 + do i=1,n + i2p3=i*2+3 + zn=znd + znd=zndd + zndd=znddd + znddd=-(znd-i2p3*zndd)/z2 + enddo + endif +endif +end subroutine znfun + +!============================================================================= +! Utility code for various Mobius transformations. If aa1,bb1,cc1,dd1 are +! the coefficients for one transformation, and aa2,bb2,cc2,dd2 are the +! coefficients for a second one, then the coefficients for the mapping +! of a test point, zz, by aa1 etc to zw, followed by a mapping of zw, by +! aa2 etc to zv, is equivalent to a single mapping zz-->zv by the transformatn +! with coefficients aa3,bb3,cc3,dd3, such that, as 2*2 complex matrices: +! +! [ aa3, bb3 ] [ aa2, bb2 ] [ aa1, bb1 ] +! [ ] = [ ] * [ ] +! [ cc3, dd3 ] [ cc2, dd2 ] [ cc1, dd1 ] . +! +! Note that the determinant of these matrices is always +1 +! +!============================================================================= +subroutine ctoz(v, z,infz)! [ctoz] +!============================================================================= +implicit none +real(dp),dimension(3),intent(IN ):: v +complex(dpc), intent(OUT):: z +logical, intent(OUT):: infz +!----------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp +real(dp) :: rr,zzpi +!============================================================================= +infz=.false. +z=cmplx(v(1),v(2),dpc) +if(v(3)>0_dp)then + zzpi=one/(one+v(3)) +else + rr=v(1)**2+v(2)**2 + infz=(rr==zero); if(infz)return ! <- The point is mapped to infinity (90S) + zzpi=(one-v(3))/rr +endif +z=z*zzpi +end subroutine ctoz + +!============================================================================= +subroutine ztoc(z,infz, v)! [ztoc] +!============================================================================= +implicit none +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3),intent(OUT):: v +!----------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp +real(dp) :: r,q,rs,rsc,rsbi +!============================================================================= +if(infz)then; v=(/zero,zero,-one/); return; endif +r=real(z); q=aimag(z); rs=r*r+q*q +rsc=one-rs +rsbi=one/(one+rs) +v(1)=2_dp*rsbi*r +v(2)=2_dp*rsbi*q +v(3)=rsc*rsbi +end subroutine ztoc + +!============================================================================= +subroutine ztocd(z,infz, v,vd)! [ztoc] +!============================================================================= +! The convention adopted for the complex derivative is that, for a complex +! infinitesimal map displacement, delta_z, the corresponding infinitesimal +! change of cartesian vector position is delta_v given by: +! delta_v = Real(vd*delta_z). +! Thus, by a kind of Cauchy-Riemann relation, Imag(vd)=v CROSS Real(vd). +! THE DERIVATIVE FOR THE IDEAL POINT AT INFINITY HAS NOT BEEN CODED YET!!! +!============================================================================= +implicit none +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3), intent(OUT):: v +complex(dpc),dimension(3),intent(OUT):: vd +!----------------------------------------------------------------------------- +real(dp),parameter :: zero=0,one=1 +real(dp) :: r,q,rs,rsc,rsbi,rsbis +real(dp),dimension(3):: u1,u2 +integer(i_kind) :: i +!============================================================================= +if(infz)then; v=(/zero,zero,-one/); return; endif +r=real(z); q=aimag(z); rs=r*r+q*q +rsc=one-rs +rsbi=one/(one+rs) +rsbis=rsbi**2 +v(1)=2_dp*rsbi*r +v(2)=2_dp*rsbi*q +v(3)=rsc*rsbi +u1(1)=2_dp*(one+q*q-r*r)*rsbis +u1(2)=-4_dp*r*q*rsbis +u1(3)=-4_dp*r*rsbis +u2=cross_product(v,u1) +do i=1,3 + vd(i)=cmplx(u1(i),-u2(i),dpc) +enddo +end subroutine ztocd + +!============================================================================ +subroutine setmobius(xc0,xc1,xc2, aa,bb,cc,dd)! [setmobius] +!============================================================================ +! Find the Mobius transformation complex coefficients, aa,bb,cc,dd, +! with aa*dd-bb*cc=1, for a standard (north-)polar stereographic transformation +! that takes cartesian point, xc0 to the north pole, xc1 to (lat=0,lon=0), +! xc2 to the south pole (=complex infinity). +!============================================================================ +implicit none +real(dp),dimension(3),intent(IN ):: xc0,xc1,xc2 +complex(dpc), intent(OUT):: aa,bb,cc,dd +!---------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp +logical :: infz0,infz1,infz2 +complex(dpc) :: z0,z1,z2,z02,z10,z21 +!============================================================================ +call ctoz(xc0,z0,infz0) +call ctoz(xc1,z1,infz1) +call ctoz(xc2,z2,infz2) +z21=z2-z1 +z02=z0-z2 +z10=z1-z0 + +if( (z0==z1.and.infz0.eqv.infz1).or.& + (z1==z2.and.infz1.eqv.infz2).or.& + (z2==z0.and.infz2.eqv.infz0)) & + stop 'In setmobius; anchor points must be distinct' + +if(infz2 .or. (.not.infz0 .and. abs(z0)=maxv)then + maxv=v(k) + maxl=left + maxk=k + endif + enddo + if(k/=maxk)then + if(maxl==0)then + first=next(maxk) + else + next(maxl)=next(maxk) + endif + next(maxk)=next(k) + next(k)=maxk + endif + enddo +else + na1=n1; na2=(n1+n2)/2; nb1=na2+1; nb2=n2 + call bsort(na1,na2,v(na1:na2),next(na1:na2),firsta) + call bsort(nb1,nb2,v(nb1:nb2),next(nb1:nb2),firstb) + call mergeab(na1,nb2,firsta,firstb, & + v(na1:nb2),next(na1:nb2), first) +endif +end subroutine bsort_s + +!============================================================================= +recursive subroutine bsort_d(n1,n2,v,next,first)! [bsort] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: n1,n2 +real(dp), dimension(n1:n2),intent(IN ):: v +integer(i_kind), dimension(n1:n2),intent( OUT):: next +integer(i_kind), intent( OUT):: first +!----------------------------------------------------------------------------- +integer(i_kind),parameter:: L=6 +integer(i_kind) :: n,na1,na2,nb1,nb2,i,j,k, maxk,maxl,left, firsta,firstb +real(dp) :: maxv +!============================================================================= +n=n2+1-n1 +if(n<=L)then +! Sort the small number of items by an order (n*n) algorithm: + do i=n1,n2-1 + next(i)=i+1 + enddo + next(n2)=0 + first=n1 + do i=n-1,1,-1 + k=first + left=0 + maxv=v(k) + maxl=left + maxk=k + do j=1,i + left=k + k=next(k) + if(v(k)>=maxv)then + maxv=v(k) + maxl=left + maxk=k + endif + enddo + if(k/=maxk)then + if(maxl==0)then + first=next(maxk) + else + next(maxl)=next(maxk) + endif + next(maxk)=next(k) + next(k)=maxk + endif + enddo +else + na1=n1; na2=(n1+n2)/2; nb1=na2+1; nb2=n2 + call bsort(na1,na2,v(na1:na2),next(na1:na2),firsta) + call bsort(nb1,nb2,v(nb1:nb2),next(nb1:nb2),firstb) + call mergeab(na1,nb2,firsta,firstb, & + v(na1:nb2),next(na1:nb2), first) +endif +end subroutine bsort_d +!============================================================================= +recursive subroutine bsort_si(n1,n2,v,next,first)! [bsort] +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: n1,n2 +integer(i_kind),dimension(n1:n2), intent(IN ):: v +integer(i_kind), dimension(n1:n2),intent( OUT):: next +integer(i_kind), intent( OUT):: first +!----------------------------------------------------------------------------- +integer(i_kind),parameter:: L=6 +integer(i_kind) :: n,na1,na2,nb1,nb2,i,j,k, maxk,maxl,left, firsta,firstb +integer(i_kind) :: maxv +!============================================================================= +n=n2+1-n1 +if(n<=L)then +! Sort the small number of items by an order (n*n) algorithm: + do i=n1,n2-1 + next(i)=i+1 + enddo + next(n2)=0 + first=n1 + do i=n-1,1,-1 + k=first + left=0 + maxv=v(k) + maxl=left + maxk=k + do j=1,i + left=k + k=next(k) + if(v(k)>=maxv)then + maxv=v(k) + maxl=left + maxk=k + endif + enddo + if(k/=maxk)then + if(maxl==0)then + first=next(maxk) + else + next(maxl)=next(maxk) + endif + next(maxk)=next(k) + next(k)=maxk + endif + enddo +else + na1=n1; na2=(n1+n2)/2; nb1=na2+1; nb2=n2 + call bsort(na1,na2,v(na1:na2),next(na1:na2),firsta) + call bsort(nb1,nb2,v(nb1:nb2),next(nb1:nb2),firstb) + call mergeab(na1,nb2,firsta,firstb, & + v(na1:nb2),next(na1:nb2), first) +endif +end subroutine bsort_si +!============================================================================= +recursive subroutine bsort_di(n1,n2,v,next,first)! [bsort] +!============================================================================= +use kinds, only: dpi +implicit none +integer(i_kind), intent(IN ):: n1,n2 +integer(dpi), dimension(n1:n2),intent(IN ):: v +integer(i_kind),dimension(n1:n2),intent( OUT):: next +integer(i_kind), intent( OUT):: first +!----------------------------------------------------------------------------- +integer(i_kind),parameter:: L=6 +integer(i_kind) :: n,na1,na2,nb1,nb2,i,j,k,maxk,maxl,left,firsta,firstb +integer(dpi) :: maxv +!============================================================================= +n=n2+1-n1 +if(n<=L)then +! Sort the small number of items by an order (n*n) algorithm: + do i=n1,n2-1 + next(i)=i+1 + enddo + next(n2)=0 + first=n1 + do i=n-1,1,-1 + k=first + left=0 + maxv=v(k) + maxl=left + maxk=k + do j=1,i + left=k + k=next(k) + if(v(k)>=maxv)then + maxv=v(k) + maxl=left + maxk=k + endif + enddo + if(k/=maxk)then + if(maxl==0)then + first=next(maxk) + else + next(maxl)=next(maxk) + endif + next(maxk)=next(k) + next(k)=maxk + endif + enddo +else + na1=n1; na2=(n1+n2)/2; nb1=na2+1; nb2=n2 + call bsort(na1,na2,v(na1:na2),next(na1:na2),firsta) + call bsort(nb1,nb2,v(nb1:nb2),next(nb1:nb2),firstb) + call mergeab(na1,nb2,firsta,firstb, & + v(na1:nb2),next(na1:nb2), first) +endif +end subroutine bsort_di + +!============================================================================= +subroutine mergeab_s(na1,nb2,firsta,firstb, v,next,first)! [mergeab] +!============================================================================= +! Merge a pair (a and b) of individually pre-sorted strings of real values, +! connected as respective linked-lists, into a unified string with ALL the +! items returned in ascending order of values v. +!============================================================================= +implicit none +integer(i_kind), intent(IN ):: na1,nb2,firsta,firstb +real(sp),dimension(na1:nb2), intent(IN ):: v +integer(i_kind), dimension(na1:nb2),intent(INOUT):: next +integer(i_kind), intent( OUT):: first +!----------------------------------------------------------------------------- +integer(i_kind),parameter :: hugeint= 10000000 +integer(i_kind) :: idum,ia,ib,ic +!============================================================================ +ia=firsta +ib=firstb +if(ia==0)then + first=firstb + return +endif +if(ib==0)then + first=firsta + return +endif +if(v(ia)nunit)& + stop'In writevqcascfile; No available unit number for writing' +open(unit=iunit,file=vqcascfile,access='sequential',form='formatted') +write(iunit,600)npx,npa,npb,npk,nx,na +write(iunit,601)sgt +write(iunit,601)swt +write(iunit,601)x1t +write(iunit,601)x2t +write(iunit,601)xat +write(iunit,601)yat +close(iunit) +600 format(6i10) +601 format(4(e19.12,1x)) +end subroutine writevqcascfile + +!============================================================================== +subroutine readvqcascfile(vqcascfile,&! [readvqcascfile] + npx_a,npa_a,npb_a,npk_a,nx_a,na_a) +!============================================================================== +! If VQC parameters already exist in the module, pvqc_tables.mod, wipe them +! clean with a call to witevqctables; then read in the integer records from +! the ascii data set given by its 12-character name, vqcascfile, and check +! whether these parameters for the tables match those specified in the +! argument list and if not, stop. Assuming the parameters match, +! allocate sufficient space in module pvqc_tables and read in the real-valued +! tables from the rest of the dataset and close it. Compute the resolutions +! dx,da,db,dk, from the given integer parameters and set the "initialized" +! flag, linitvqc, to .true. +!============================================================================== +use pvqc_tables, only: sgt,swt,x1t,x2t,xat,yat, dx,da,db,dk, & + npx,npa,npb,npk,nx,na,npb2, linitvqc +implicit none +character(len=12),intent(in ):: vqcascfile +integer(i_kind), intent(in ):: npx_a,npa_a,npb_a,npk_a,nx_a,na_a +!------------------------------------------------------------------------------ +integer(i_kind),parameter:: lunit=11,nunit=99 +integer(i_kind) :: iunit,nkm +logical :: ex,op +!============================================================================== +if(linitvqc)call wipevqctables +do iunit=lunit,nunit + inquire(unit=iunit, exist=ex, opened=op) + if(.not.ex)exit + if(.not.op)exit +enddo +if(.not.ex .or. iunit>nunit)& + stop'In readvqcascfile; No available unit number for reading' +open(unit=iunit,file=vqcascfile,access='sequential',form='formatted') +read(iunit,600)npx,npa,npb,npk,nx,na +if(npx_a/=npx)stop'In readvqcascfile; mismatched specified npx' +if(npa_a/=npa)stop'In readvqcascfile; mismatched specified npa' +if(npb_a/=npb)stop'In readvqcascfile; mismatched specified npb' +if(npk_a/=npk)stop'In readvqcascfile; mismatched specified npk' +if(nx_a /=nx )stop'In readvqcascfile; mismatched specified nx' +if(na_a /=na )stop'In readvqcascfile; mismatched specified na' +nkm=npk-1 +npb2=npb*2 +allocate(sgt(-nx:nx,0:na,-nkm:nkm),swt(-nx:nx,0:na,-nkm:nkm),& + x1t(0:na,-nkm:nkm),x2t(0:na,-nkm:nkm),& + xat(0:na,-nkm:nkm),yat(0:na,-nkm:nkm)) +read(iunit,601)sgt +read(iunit,601)swt +read(iunit,601)x1t +read(iunit,601)x2t +read(iunit,601)xat +read(iunit,601)yat +close(iunit) +dx=u1/npx +da=u1/npa +db=u1/npb +dk=u1/npk +linitvqc=T +600 format(6i10) +601 format(4(e19.12,1x)) +end subroutine readvqcascfile + +!============================================================================== +subroutine writevqcdatfile(vqcdatfile,&! [writevqcdatfile] + npx_a,npa_a,npb_a,npk_a,nx_a,na_a) +!============================================================================== +! If VQC parameters and tables have been created, or read in, and now exist in +! the module, pvqc_tables.mod, with its "initialized" flag, linitvqc indicated +! (=.true.), this routine will write a binary copy of the entire table to the +! file specified by the 12-character filename given by the character argument, +! vqcdatfile, provided that the specification parameters in pvqc_tables +! match those listed in the rest of the argument list. +!============================================================================== +use pvqc_tables, only: sgt,swt,x1t,x2t,xat,yat, & + npx,npa,npb,npk,nx,na, linitvqc +implicit none +character(len=12),intent(in ):: vqcdatfile +integer(i_kind), intent(in ):: npx_a,npa_a,npb_a,npk_a,nx_a,na_a +!------------------------------------------------------------------------------ +integer(i_kind),parameter:: lunit=11,nunit=99 +integer(i_kind) :: iunit +logical :: ex,op +!============================================================================== +if(.not.linitvqc)& + stop'In writevqcdatfile; VQC parameters and tables are not yet initialized' +if(npx_a/=npx)stop'In writevqcdatfile; mismatched specified npx' +if(npa_a/=npa)stop'In writevqcdatfile; mismatched specified npa' +if(npb_a/=npb)stop'In writevqcdatfile; mismatched specified npb' +if(npk_a/=npk)stop'In writevqcdatfile; mismatched specified npk' +if(nx_a /=nx )stop'In writevqcdatfile; mismatched specified nx' +if(na_a /=na )stop'In writevqcdatfile; mismatched specified na' + +do iunit=lunit,nunit + inquire(unit=iunit, exist=ex, opened=op) + if(.not.ex)exit + if(.not.op)exit +enddo +if(.not.ex .or. iunit>nunit)& + stop'In writevqcdatfile; No available unit number for writing' +open(unit=iunit,file=vqcdatfile,access='sequential',form='unformatted') +write(unit=iunit)npx,npa,npb,npk,nx,na +write(iunit)sgt +write(iunit)swt +write(iunit)x1t +write(iunit)x2t +write(iunit)xat +write(iunit)yat +close(iunit) +end subroutine writevqcdatfile + +!============================================================================== +subroutine readvqcdatfile(vqcdatfile,&! [readvqcdatfile] + npx_a,npa_a,npb_a,npk_a,nx_a,na_a) +!============================================================================== +! If VQC parameters already exist in the module, pvqc_tables.mod, wipe them +! clean with a call to witevqctables; then read in the integer records from +! the binary data set given by its 12-character name, vqcdatfile, and check +! whether these parameters for the tables match those specified in the +! argument list and if not, stop. Assuming the parameters match, +! allocate sufficient space in module pvqc_tables and read in the real-valued +! tables from the rest of the dataset and close it. Compute the resolutions +! dx,da,db,dk, from the given integer parameters and set the "initialized" +! flag, linitvqc, to .true. +!============================================================================== +use pvqc_tables, only: sgt,swt,x1t,x2t,xat,yat, dx,da,db,dk, & + npx,npa,npb,npk,nx,na,npb2, linitvqc +character(len=12),intent(in ):: vqcdatfile +integer(i_kind), intent(in ):: npx_a,npa_a,npb_a,npk_a,nx_a,na_a +!------------------------------------------------------------------------------ +integer(i_kind),parameter:: lunit=11,nunit=99 +integer(i_kind) :: iunit,nkm +logical :: ex,op +!============================================================================== +if(linitvqc)call wipevqctables +do iunit=lunit,nunit + inquire(unit=iunit, exist=ex, opened=op) + if(.not.ex)exit + if(.not.op)exit +enddo +if(.not.ex .or. iunit>nunit)& + stop'In readvqcdatfile; No available unit number for reading' +open(unit=iunit,file=vqcdatfile,access='sequential',form='unformatted') +read(iunit)npx,npa,npb,npk,nx,na +if(npx_a/=npx)stop'In readvqcdatfile; mismatched specified npx' +if(npa_a/=npa)stop'In readvqcdatfile; mismatched specified npa' +if(npb_a/=npb)stop'In readvqcdatfile; mismatched specified npb' +if(npk_a/=npk)stop'In readvqcdatfile; mismatched specified npk' +if(nx_a /=nx )stop'In readvqcdatfile; mismatched specified nx' +if(na_a /=na )stop'In readvqcdatfile; mismatched specified na' +nkm=npk-1 +npb2=npb*2 +allocate(sgt(-nx:nx,0:na,-nkm:nkm),swt(-nx:nx,0:na,-nkm:nkm),& + x1t(0:na,-nkm:nkm),x2t(0:na,-nkm:nkm),& + xat(0:na,-nkm:nkm),yat(0:na,-nkm:nkm)) +read(iunit)sgt +read(iunit)swt +read(iunit)x1t +read(iunit)x2t +read(iunit)xat +read(iunit)yat +close(iunit) +dx=u1/npx +da=u1/npa +db=u1/npb +dk=u1/npk +linitvqc=T +end subroutine readvqcdatfile + +!============================================================================== +subroutine vqch_iii(ia,ib,ik,x,g,w)! [vqch] +!============================================================================== +! Huber-like analog of the superlogistic routine vqcs. The results, g and w, +! in the central section are ezactly as if the density is a standardized +! Gaussian; outside points where this Gaussian becomes tangent to the +! idealized superlogistic's asymptotes, the results returned are those that +! take these asymptotes to be the effective log-probability (with suitable +! small nudges, xa in x, and ya in the g direction, to ensure the tengential +! intersections occur when the log-gaussian (parabola) is properly centered +! and peaks at g=0). +!============================================================================== +use pvqc_tables, only: x1t,x2t,xat,yat,da,db,dk,& + npk,na,npb2,linitvqc +implicit none +integer(i_kind), intent(in ):: ia,ib,ik +real(dp), intent(in ):: x +real(dp), intent(out):: g,w +!------------------------------------------------------------------------------ +real(dp),parameter:: pio4=pi/4_dp +real(dp) :: bc,p,q,qx,sx,alpha,beta,kappa, & + x1,x2,xa,ya,xx +integer(i_kind) :: ja +!============================================================================== +if(.not.linitvqc)stop'In vqch; VQC tables are not initialized' +if(ia<0)then; sx=-x; ja=-ia +else; sx= x; ja= ia +endif +if(ja>na )stop'In vqch; ia out of bounds' +if(ib<=0.or.ib>=npb2 )stop'In vqch; ib out of bounds' +if(ik<=-npk.or.ik>=npk)stop'In vqch; ik out of bounds' +x1=x1t(ja,ik) +x2=x2t(ja,ik) +xa=xat(ja,ik) +ya=yat(ja,ik) +alpha=ja*da +beta =ib*db +kappa=ik*dk +bc=tan(pio4*(u2-beta)) +p=bc**(u2/(u1-kappa)) +q=u1/sqrt(p) +qx=q*sx +xx=qx+xa +if(qxx2)then + call atote(alpha,u1,kappa,xx,g,w) + g=g-ya + w=-w/xx +else + g=-qx**2/2 + w=1 +endif +g=p*g +end subroutine vqch_iii +!============================================================================== +subroutine vqch_ii(ib,ik,x,g,w)! [vqch] +!============================================================================== +! Wrapper for the symmetric restriction (no alpha index) of the Huber-like +! analogs of the superlogistic family. +!============================================================================== +implicit none +integer(i_kind), intent(in ):: ib,ik +real(dp), intent(in ):: x +real(dp), intent(out):: g,w +!------------------------------------------------------------------------------ +call vqch(0,ib,ik,x,g,w) +end subroutine vqch_ii +!============================================================================== +subroutine vqch_i(ib,x,g,w)! [vqch] +!============================================================================== +! Wrapper for the symmetric (no alpha index) and neutrally-convex +! (no kappa index) restriction of the Huber-like analogs of the +! superlogistic family. +!============================================================================== +integer(i_kind), intent(in ):: ib +real(dp), intent(in ):: x +real(dp), intent(out):: g,w +!------------------------------------------------------------------------------ +call vqch(0,ib,0,x,g,w) +end subroutine vqch_i +!============================================================================== +subroutine vqch_r(beta,x,g,w)! [vqch] +!============================================================================== +! Huber-norm analog of the simplest versions of the superlogistic +! (symmetric, neutral convexity), with tail broadness specified by a real +! parameter, beta. +!============================================================================== +use pvqc_tables, only: x1t,x2t,yat,linitvqc +implicit none +real(dp),intent(in ):: beta,x +real(dp),intent(out):: g,w +!------------------------------------------------------------------------------ +real(dp),parameter:: pio4=pi/4_dp +real(dp) :: bc,p,q,qx,x1,x2,ya,xx +!============================================================================== +if(.not.linitvqc)stop'In vqch; VQC tables are not initialized' +if(beta<=u0.or.beta>=u2)stop'In vqch; beta out of bounds' +x1=x1t(0,0) +x2=x2t(0,0) +ya=yat(0,0) +bc=tan(pio4*(u2-beta)) +p=bc**2 +q=u1/bc +qx=q*x +xx=qx +if(qxx2)then + call atote(u0,u1,u0,xx,g,w) + g=g-ya + w=-w/xx +else + g=-qx**2/2_dp + w=1_dp +endif +g=p*g +end subroutine vqch_r + +!============================================================================== +subroutine vqcs_iii(ia,ib,ik,x,g,w)! [vqcs] +!============================================================================== +! By specifying the tail-shape parameters, Alpha (Asymmetry), Beta (Broadness) +! and Konvexity (Kappa) by their integer indices, ia, ib, ik, subject to the +! understood convention that there are npa index steps per unit alpha, npb +! per unit beta, npk per unit kappa, this routine will return the +! log-probability, g (which is the negative of the cost function contribution) +! and the weight-factor, w, appropriate to the standardized O-A given by x. +! Provided that the the (x,beta) combination maintains the rescaling +! of this x, namely qx, within the span of the prepared tables, the g and w +! are evaluated by Hermite interpolation (in qx) from the superlogistic +! function table, but when the rescaled residual is too large to fit within +! the span of the table, the returned values are those of the almost +! equivalent Huber-like analog contrived to possess exactly the same +! asymptotic form in the limit |x| --> infinity, and slightly adjusted to +! ensure continuity of g at the transition. +!============================================================================== +use pvqc_tables, only: sgt,swt,dx,db,dk,npb,npk,nx,na,npb2,linitvqc +implicit none +integer(i_kind), intent(in ):: ia,ib,ik +real(dp), intent(in ):: x +real(dp), intent(out):: g,w +!------------------------------------------------------------------------------ +real(dp),parameter:: pio4=pi/4 +real(dp) :: bc,p,q,qx,sx,w1,w2,xodx,beta,kappa,xe,ge,we,& + ww,dfa,fl,dfl,f1,f2,df1,df2,g1,g2 +integer(i_kind) :: ix1,ix2,ja +!============================================================================== +if(.not.linitvqc)stop'In vqcs; VQC tables are not initialized' +if(ia<0)then; sx=-x; ja=-ia +else; sx= x; ja= ia +endif +if(ja>na )stop'In vqcs; ia out of bounds' +if(ib<=0.or.ib>=npb2 )stop'In vqcs; ib out of bounds' +if(ik<=-npk.or.ik>=npk)stop'In vqcs; ik out of bounds' +beta =ib*db +kappa=ik*dk +bc=tan(pio4*(u2-beta)) +p=bc**(u2/(u1-kappa)) +q=u1/sqrt(p) +qx=q*sx +xodx=qx/dx +ix1=floor(xodx); ix2=ix1+1 +if (ix1<-nx)then + xe=-nx*dx + call vqch(ja,npb,ik,qx,g, w ) + call vqch(ja,npb,ik,xe,ge,we) + g=p*(sgt(-nx,ja,ik)+g-ge) +elseif(ix2>nx)then + xe= nx*dx + call vqch(ja,npb,ik,qx,g, w ) + call vqch(ja,npb,ik,xe,ge,we) + g=p*(sgt( nx,ja,ik)+g-ge) +else + w1=ix2-xodx + w2=xodx-ix1 + f1=-sgt(ix1,ja,ik) + f2=-sgt(ix2,ja,ik) + df1=swt(ix1,ja,ik) + df2=swt(ix2,ja,ik) + fl=w1*f1+w2*f2 + ww=w1*w2 + if(ww==u0)then + g=-p*fl + w= w1*df1+w2*df2 + else +! Hermite interpolation for g and its consistent derivative used for w: + df1=df1*ix1*dx + df2=df2*ix2*dx + dfl=w1*df1+w2*df2 + dfa=(f2-f1)/dx + g1=df1-dfa + g2=df2-dfa + g=-p*(fl+ww*dx*(w1*g1-w2*g2)) + w=(dfl-3*ww*(g1+g2))/qx + endif +endif +end subroutine vqcs_iii +!============================================================================== +subroutine vqcs_ii(ib,ik,x,g,w)! [vqcs] +!============================================================================== +! On the assumption that asymmetry (alpha) is rarely needed, this wrapper +! dispenses with the associated index parameter ia for the convenience of the +! user, but retains broadness and convexity indices, ib and ik. +!============================================================================== +implicit none +integer(i_kind), intent(in ):: ib,ik +real(dp), intent(in ):: x +real(dp), intent(out):: g,w +!------------------------------------------------------------------------------ +call vqcs(0,ib,ik,x,g,w) +end subroutine vqcs_ii +!============================================================================== +subroutine vqcs_i(ib,x,g,w)! [vqcs] +!============================================================================== +! For the restricted case of the symmetric powers of the classical logistic +! this wrapper routine takes only the beta parameter index, ib, to define +! the broadness. +!============================================================================== +implicit none +integer(i_kind), intent(in ):: ib +real(dp), intent(in ):: x +real(dp), intent(out):: g,w +!------------------------------------------------------------------------------ +call vqcs(0,ib,0,x,g,w) +end subroutine vqcs_i +!============================================================================== +subroutine vqcs_r(beta,x,g,w)! [vqcs] +!============================================================================== +! A special version of vqcs with vanishing asymmetry and neutral convexity, +! but accepting a real parameter, beta, for broadness in order to make it +! more compatible with the older version of VQC that uses these simpler forms +! of the superlogistic family. +!============================================================================== +use pvqc_tables, only: sgt,swt,dx,npb,nx,linitvqc +implicit none +real(dp),intent(in ):: beta,x +real(dp),intent(out):: g,w +!------------------------------------------------------------------------------ +real(dp),parameter:: pio4=pi/4_dp +real(dp) :: bc,p,q,qx,w1,w2,xodx,xe,ge,we,& + ww,dfa,fl,dfl,f1,f2,df1,df2,g1,g2 +integer(i_kind) :: ix1,ix2 +!============================================================================== +if(.not.linitvqc)stop'In vqcs; VQC tables are not initialized' +bc=tan(pio4*(u2-beta)) +p=bc**2 +q=u1/bc +qx=q*x +xodx=qx/dx +ix1=floor(xodx); ix2=ix1+1 +if(ix1<-nx)then + xe=-nx*dx + call vqch(npb,qx,g, w ) + call vqch(npb,xe,ge,we) + g=p*(sgt(-nx,0,0)+g-ge) +elseif(ix2>nx)then + xe= nx*dx + call vqch(npb,qx,g, w ) + call vqch(npb,xe,ge,we) + g=p*(sgt( nx,0,0)+g-ge) +else + w1=ix2-xodx + w2=xodx-ix1 + f1=-sgt(ix1,0,0) + f2=-sgt(ix2,0,0) + df1=swt(ix1,0,0) + df2=swt(ix2,0,0) + fl=w1*f1+w2*f2 + ww=w1*w2 + if(ww==u0)then + g=-p*fl + w= w1*df1+w2*df2 + else +! Hermite interpolation for g and its consistent derivative used for w: + df1=df1*ix1*dx + df2=df2*ix2*dx + dfl=w1*df1+w2*df2 + dfa=(f2-f1)/dx + g1=df1-dfa + g2=df2-dfa + g=-p*(fl+ww*dx*(w1*g1-w2*g2)) + w=(dfl-3*ww*(g1+g2))/qx + endif +endif +end subroutine vqcs_r + +end module pvqc diff --git a/src/gsi/pvqc_tables.f90 b/src/gsi/pvqc_tables.f90 new file mode 100755 index 0000000000..25bf8ca9ed --- /dev/null +++ b/src/gsi/pvqc_tables.f90 @@ -0,0 +1,40 @@ +! ************************** +! * MODULE pvqc_tables * +! * R. J. Purser * +! * NOAA/NCEP/EMC 2017 * +! ************************** +! Parameters and tables defining the three-shape-parameter variational +! quality control (VQC) scheme of the super-logictic kind (NOAA/NCEP Office +! Note 468) together with corresponding analogs of the Huber-like type +! (see Tavolato and Isaksen, 2015). +! +! DIRECT DEPENDENCIES +! Modules: kind +! +!============================================================================= +module pvqc_tables +!============================================================================= +! sgt: super-logistic standardized log-probability table (but unnormalized) +! swt: super-logistic standardized weight-factor table +! x1t,x2t: Tables of the negative and positive transition pts in the +! Huber-like analogs of the standardized probability models +! xat,yat: translation parameter tables for centering the Huber-like models +! npx: Resolution, points per unit x of tables sgt and swt +! npa: Resolution, points per unit alpha in all tables +! npb: Nominal resolution, points per unit beta, but independent of the tables +! npk: Resolution, points per unit kappa in all tables +! nx: size [-nx:nx] of centered table in x +! na: size [0:na] of one-sided table in alpha +! linitvqc: logical flag, true only when tables are initialized +!============================================================================= +use kinds, only: dp,i_kind +implicit none +public +real(dp),allocatable,dimension(:,:,:):: sgt,swt +real(dp),allocatable,dimension(:,:) :: x1t,x2t,xat,yat +real(dp) :: dx,da,db,dk +integer(i_kind) :: npx,npa,npb,npk,nx,na,npb2 +logical :: linitvqc +data linitvqc/.false./ +end module pvqc_tables + diff --git a/src/gsi/q_diag.f90 b/src/gsi/q_diag.f90 index 2ab12872c7..925a5775ec 100644 --- a/src/gsi/q_diag.f90 +++ b/src/gsi/q_diag.f90 @@ -34,7 +34,7 @@ subroutine q_diag(it,mype) !$$$ use kinds, only: r_kind,i_kind use guess_grids, only: ges_qsat,ges_prsi - use jfunc, only: iout_iter + use jfunc, only: iout_iter,jiter use mpimod, only: mpi_rtype,mpi_comm_world,mpi_sum,ierror use constants,only: zero,two,one,half use gridmod, only: lat2,lon2,nsig,nlat,nlon,lat1,lon1,iglobal,& @@ -133,12 +133,15 @@ subroutine q_diag(it,mype) if(qrms0(1,3)>zero) rhrms_neg=sqrt(qrms0(1,2)/qrms0(1,3)) if(qrms0(2,2)>zero) qrms_sat =sqrt(qrms0(2,1)/qrms0(2,3)) if(qrms0(2,3)>zero) rhrms_sat=sqrt(qrms0(2,2)/qrms0(2,3)) - write(iout_iter,100) nint(qrms0(1,3)),qrms_neg,nint(qrms0(1,3)),rhrms_neg, & - nint(qrms0(2,3)),qrms_sat,nint(qrms0(2,3)),rhrms_sat -100 format(' Q_DIAG: NEG Q COUNT,RMS=',i9,1x,g13.6,/, & - ' NEG RH COUNT,RMS=',i9,1x,g13.6,/, & - ' SUPERSAT Q COUNT,RMS=',i9,1x,g13.6,/, & - ' SUPERSAT RH COUNT,RMS=',i9,1x,g13.6) + write(iout_iter,100) & + jiter,nint(qrms0(1,3)),qrms_neg,& + jiter,nint(qrms0(1,3)),rhrms_neg, & + jiter,nint(qrms0(2,3)),qrms_sat, & + jiter,nint(qrms0(2,3)),rhrms_sat +100 format(' Q_DIAG: ',i2.2,' NEG Q COUNT,RMS=',i9,1x,g19.12,/, & + ' ',i2.2,' NEG RH COUNT,RMS=',i9,1x,g19.12,/, & + ' ',i2.2,' SUPERSAT Q COUNT,RMS=',i9,1x,g19.12,/, & + ' ',i2.2,' SUPERSAT RH COUNT,RMS=',i9,1x,g19.12) call load_grid(work_ps,grid_ps) call load_grid(work_pw,grid_pw) @@ -161,8 +164,8 @@ subroutine q_diag(it,mype) globps=globps globpw=globpw pdryini=globps-globpw - write(iout_iter,110) globps,globpw,pdryini -110 format(' Q_DIAG: mean_ps, mean_pw, pdryini=',3(g13.6,1x)) + write(iout_iter,110) jiter,globps,globpw,pdryini +110 format(' Q_DIAG: ',i2.2,' mean_ps, mean_pw, pdryini=',3(g19.12,1x)) end if return diff --git a/src/gsi/qcmod.f90 b/src/gsi/qcmod.f90 index 09670c0414..294b6e1443 100644 --- a/src/gsi/qcmod.f90 +++ b/src/gsi/qcmod.f90 @@ -75,6 +75,8 @@ module qcmod ! 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-06-10 h. liu - add Geostationary satellites CSR data QC to replace qc_abi,qc_seviri +! 2019-09-29 X.Su - add troflg and lat_c for hilbert curve tunning ! 2019-04-19 eliu - add QC flag for cold-air outbreak ! ! subroutines included: @@ -86,7 +88,6 @@ module qcmod ! sub setup_tzr_qc - set up QC with Tz retrieval ! sub tz_retrieval - Apply Tz retrieval ! sub qc_ssmi - qc ssmi data -! sub qc_seviri - qc seviri data ! sub qc_ssu - qc ssu data ! sub qc_avhrr - qc avhrr data ! sub qc_goesimg - qc goesimg data @@ -98,7 +99,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 +! sub qc_geocsr - qc goestationary satellite data ! ! remarks: variable definitions below ! def dfact - factor for duplicate obs at same location for conv. data @@ -117,6 +118,9 @@ module qcmod ! ! def nlnqc_iter - logical flag (T=nonlinear qc on, F=nonlinear qc off) for iteration ! def njqc - logical flag (T=Purser's nonlinear qc on, F=off) +! def vqc - logical flag (T=EC vqc on, F=off) +! def nvqc - logical flag (T=new vqc on, F=off) +! def hub_norm - logical flag (T=mix vqc model, F=logistic model) ! def noiqc - logic flag for oiqc, noiqc='false' with oiqc on ! ! following used for NonLinear TRansformation to visibility and ceiling height @@ -128,6 +132,12 @@ module qcmod ! def vis_thres - threshold value for vis ! def cldch_thres - threshold value for cldch ! +! this for hilbert curve tunning +! def troflg - if tro flg is on different region will have different +! down weighting criteria when appling HIlbert curve +! def lat_c - the latitude criteria for different down weighting +! criteria +! def nrand - hilbert premeter ! ! attributes: ! language: f90 @@ -155,10 +165,9 @@ module qcmod public :: errormod_aircraft public :: setup_tzr_qc public :: qc_ssmi - public :: qc_seviri public :: qc_ssu public :: qc_goesimg - public :: qc_abi + public :: qc_geocsr public :: qc_msu public :: qc_irsnd public :: qc_avhrr @@ -172,7 +181,7 @@ module qcmod public :: qc_amsr2 public :: qc_saphir ! set passed variables to public - public :: npres_print,nlnqc_iter,varqc_iter,pbot,ptop,c_varqc,njqc,vqc + public :: npres_print,nlnqc_iter,varqc_iter,pbot,ptop,c_varqc,njqc,vqc,nvqc,hub_norm 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,& @@ -185,8 +194,11 @@ module qcmod public :: buddycheck_t,buddydiag_save public :: vadwnd_l2rw_qc public :: pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres + public :: troflg + public :: lat_c + public :: nrand - logical nlnqc_iter,njqc,vqc + logical nlnqc_iter,njqc,vqc,nvqc,hub_norm logical noiqc logical use_poq7 logical qc_noirjaco3 @@ -197,12 +209,15 @@ module qcmod logical buddycheck_t logical buddydiag_save logical vadwnd_l2rw_qc + logical troflg logical cao_check character(10):: vadfile integer(i_kind) npres_print + integer(i_kind) nrand real(r_kind) dfact,dfact1,erradar_inflate,c_varqc real(r_kind) varqc_iter + real(r_kind) lat_c real(r_kind) pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres real(r_kind),allocatable,dimension(:)::ptop,pbot,ptopq,pbotq,ptopo3,pboto3 @@ -333,9 +348,9 @@ 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_geocsr +! Reject because of standard deviation in subroutine qc_geocsr + integer(i_kind),parameter:: ifail_std_geocsr_qc=50 ! QC_avhrr ! Reject because of too large surface temperature physical retrieval in qc routine: tz_retrieval (see tzr_qc) @@ -403,6 +418,8 @@ subroutine init_qcvars noiqc = .false. njqc=.false. vqc=.false. + nvqc=.false. + hub_norm=.true. c_varqc=one vadfile='none' @@ -428,6 +445,10 @@ subroutine init_qcvars vis_thres=16000.0_r_kind cldch_thres=16000.0_r_kind + troflg=.false. + lat_c=21.0_r_kind + nrand=13 + return end subroutine init_qcvars @@ -2878,7 +2899,7 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & ! If window channels are missing, skip the following QC and do not ! assimilate channels 1-6 & 15. - if (any(abs(tbc((/ ich238, ich314, ich503, ich528, ich536, ich544, ich890 /))) & + if (any(abs(tbc((/ ich238, ich314, ich528, ich536, ich544, ich890 /))) & > 200.0_r_kind)) then errf(1:ich544)=zero @@ -3296,7 +3317,7 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & ework = ework+min(0.002_r_kind*sfc_speed**2*error0(i), 0.5_r_kind*error0(i)) clwtmp=min(abs(clwp_amsua-clw_guess_retrieval), one) ework = ework+min(13.0_r_kind*clwtmp*error0(i), 3.5_r_kind*error0(i)) - if (scatp>9.0_r_kind) then + if (scatp>9.0_r_kind .and. nchanl==15) then ework = ework+min(1.5_r_kind*(scatp-9.0_r_kind)*error0(i), 2.5_r_kind*error0(i)) end if ework=ework**2 @@ -3816,14 +3837,15 @@ subroutine qc_msu(nchanl,is,ndat,nsig,sea,land,ice,snow,luse, & return end subroutine qc_msu -subroutine qc_seviri(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & - zsges,tzbgr,tbc,tnoise,temp,wmix,emissivity_k,ts, & + +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) ! id_qc,aivals,errf,varinv,radmod) ! all-sky !$$$ subprogram documentation block ! . . . -! subprogram: qc_seviri QC for seviri data +! subprogram: qc_goesimg QC for seviri data ! ! prgmmr: H. Liu org: np23 date: 2010-08-20 ! @@ -3831,20 +3853,23 @@ subroutine qc_seviri(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & ! ! program history log: ! 2010-08-10 derber transfered from setuprad -! 2015-09-16 sienkiewicz add terrain flag for qc marks ! ! input argument list: ! nchanl - number of channels per obs ! ich - channel number ! is - integer counter for number of observation types to process +! dplat - satellite identifier ! sea - logical, sea flag ! land - logical, land flag ! ice - logical, ice flag ! snow - logical, snow flag ! luse - logical use flag ! zsges - elevation of guess -! tzbgr - water temperature of FOV -! tbc - simulated - observed BT with bias correction +! cld - cloud percentage within averaging box +! tzbgr - surface temperature of FOV +! tb_obs - observed BT within averaging box +! tb_obs_sdv - observed BT standard deviation within averaging box +! tbc - bias corrected (observed - simulated brightness temperatures) ! tnoise - error of observed radiance ! temp - temperature sensitivity array ! wmix - moisture sensitivity array @@ -3876,89 +3901,144 @@ subroutine qc_seviri(nchanl,is,ndat,nsig,ich,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 - real(r_kind), intent(in ) :: zsges - real(r_kind), intent(in ) :: tzbgr + real(r_kind), intent(in ) :: zsges,cld,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(in ) :: tb_obs,tb_obs_sdv,tbc,tnoise,emissivity_k,ts real(r_kind),dimension(nchanl), intent(inout) :: errf,varinv + character(10), intent(in ) :: dplat ! Declare local parameters - integer(i_kind), dimension(nchanl) :: irday - real(r_kind) :: demisf,dtempf,efact,vfact,dtbf,term + real(r_kind),parameter:: r40=40.0_r_kind + real(r_kind),parameter:: r70=70.0_r_kind + real(r_kind),parameter:: r0_3=0.3_r_kind + real(r_kind),parameter:: r0_4=0.4_r_kind + real(r_kind),parameter:: r0_6=0.6_r_kind + real(r_kind),parameter:: r0_7=0.7_r_kind + real(r_kind),parameter:: r0_8=0.8_r_kind + real(r_kind),parameter:: r0_9=0.9_r_kind + real(r_kind),parameter:: r1_1=1.1_r_kind + real(r_kind),parameter:: r1_3=1.3_r_kind + real(r_kind),parameter:: r1_4=1.4_r_kind + + + real(r_kind) :: demisf,dtempf,efact,vfact,dtbf,term,fact2,fact3,fact4,fact5 + real(r_kind) :: fact integer(i_kind) :: i + integer(i_kind), dimension(nchanl) :: irday real(r_kind) :: dtz,ts_ave,xindx,tzchks irday = 1 - if(sea)then - demisf = r0_01 - dtempf = half - else if(land)then - demisf = r0_02 - dtempf = two - else if(ice)then - demisf = r0_02 - dtempf = three - else if(snow)then - demisf = r0_02 - dtempf = three - else - demisf = r0_02 - dtempf = five - end if - do i=1,nchanl -! use chn 2 and 3 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 ) then - efact=one - vfact=one - else - efact=zero - vfact=zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_surface_qc - end if + + if(tb_obs(1) > zero .and. tb_obs(2) > zero .and. tb_obs(3) > zero .and. & + tb_obs(4) > zero)then + efact = one + vfact = one + fact2 = one + fact3 = one + fact4 = one + fact5 = one + if(sea)then + demisf = r0_01 + dtempf = half + else if(land)then + do i=1,4 + if(i /= 2)then + varinv(i)=zero + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_surface_qc + end if + end do + demisf = r0_01 + dtempf = two + else if(ice)then + do i=1,4 + varinv(i)=zero + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_surface_qc + end do + demisf = r0_02 + dtempf = three + else if(snow)then + do i=1,4 + varinv(i)=zero + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_surface_qc + end do + demisf = r0_02 + dtempf = three else - efact=zero - vfact=zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_surface_qc + do i=1,4 + varinv(i)=zero + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_surface_qc + end do + demisf = r0_02 + dtempf = five end if -! Reduce weight for obs over higher topography -! QC_terrain: If seviri and terrain height > 1km. do not use - if (zsges > r1000) then - efact = zero - vfact = zero - if(id_qc(i) == igood_qc ) id_qc(i)=ifail_terrain_qc -! QC2 in statsrad - if(luse)aivals(9,is)= aivals(9,is) + one +! Filter out data according to clear sky fraction + if(dplat == 'g10' .and. cld 2.0 do not use - if ( abs(tbc(i)) > two ) then - vfact = zero - efact = zero - if(id_qc(i) == igood_qc ) id_qc(i)=ifail_gross_routine_qc !hliu check -! QC1 in statsrad - if(luse)aivals(8,is)= aivals(8,is) + one !hliu check +! Quality control according to brightness temperature +! standard deviation from data + if(tb_obs_sdv(1) >one ) then + varinv(1)=zero +! QC3 in statsrad + if(luse)aivals(10,is)= aivals(10,is) + one + if(id_qc(1) == igood_qc ) id_qc(1)=ifail_std_goesimg_qc end if -! modified variances. - errf(i) = efact*errf(i) - varinv(i) = vfact*varinv(i) - end do + if(tb_obs_sdv(2) >1.5_r_kind ) then + varinv(2)=zero +! QC4 in statsrad + if(luse)aivals(11,is)= aivals(11,is) + one + if(id_qc(2) == igood_qc ) id_qc(2)=ifail_std_goesimg_qc + end if + + if(tb_obs_sdv(3) >one ) then + varinv(3)=zero +! QC5 in statsrad + if(luse)aivals(12,is)= aivals(12,is) + one + if(id_qc(3) == igood_qc ) id_qc(3)=ifail_std_goesimg_qc + end if + + if(tb_obs_sdv(4) >one ) then + varinv(4)=zero +! QC6 in statsrad + if(luse)aivals(13,is)= aivals(13,is) + one + if(id_qc(4) == igood_qc ) id_qc(4)=ifail_std_goesimg_qc + end if +! Reduce weight for obs over higher topography + if (zsges > r2000) then + fact = r2000/zsges + efact = fact + vfact = fact*vfact +! QC2 in statsrad + if(luse)aivals(9,is)= aivals(9,is) + one + end if + else + vfact=zero + end if ! ! Apply Tz retrieval ! if(tzr_qc > 0)then dtz = rmiss_single - if (sea ) then + if ( sea ) then call tz_retrieval(nchanl,nsig,ich,irday,temp,wmix,tnoise,varinv,ts,tbc,tzbgr,1,0,dtz,ts_ave) endif ! @@ -3980,31 +4060,62 @@ subroutine qc_seviri(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & endif endif - do i = 1, nchanl -! Modify error based on transmittance at top of model -! need this for SEVIRI?????? -! varinv(i)=varinv(i)*ptau5(nsig,i) -! errf(i)=errf(i)*ptau5(nsig,i) - - 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) +! Generate q.c. bounds and modified variances. + do i=1,nchanl + varinv(i) = vfact*varinv(i) + if( dplat == 'g10' .and. i== 2) then + if (tb_obs_sdv(2) >r0_3 .and. tb_obs_sdv(2) <=r0_6) & + varinv(i)=varinv(i)/1.05_r_kind + if (tb_obs_sdv(2) >r0_6 .and. tb_obs_sdv(2) <=r0_7) & + varinv(i)=varinv(i)/1.15_r_kind + if (tb_obs_sdv(2) >r0_7 .and. tb_obs_sdv(2) <=r0_8) & + varinv(i)=varinv(i)/1.24_r_kind + if (tb_obs_sdv(2) >r0_8 .and. tb_obs_sdv(2) <=r0_9) & + varinv(i)=varinv(i)/1.28_r_kind + if (tb_obs_sdv(2) >r0_9 .and. tb_obs_sdv(2) <=one) & + varinv(i)=varinv(i)/1.32_r_kind + if (tb_obs_sdv(2) >one .and. tb_obs_sdv(2) <=r1_1) & + varinv(i)=varinv(i)/1.35_r_kind + if (tb_obs_sdv(2) >r1_1 .and. tb_obs_sdv(2) <=r1_3) & + varinv(i)=varinv(i)/1.39_r_kind + if (tb_obs_sdv(2) >r1_4 ) & + varinv(i)=varinv(i)/1.48_r_kind + else if(dplat == 'g12' .and. i== 2) then + if (tb_obs_sdv(2) >r0_4 .and. tb_obs_sdv(2) <=half) & + varinv(i)=varinv(i)/1.05_r_kind + if (tb_obs_sdv(2) >half .and. tb_obs_sdv(2) <=r0_6) & + varinv(i)=varinv(i)/1.09_r_kind + if (tb_obs_sdv(2) >r0_6 .and. tb_obs_sdv(2) <=r0_7) & + varinv(i)=varinv(i)/1.14_r_kind + if (tb_obs_sdv(2) >r0_7 .and. tb_obs_sdv(2) <=r0_8) & + varinv(i)=varinv(i)/1.17_r_kind + if (tb_obs_sdv(2) >r0_8 .and. tb_obs_sdv(2) <=r1_1) & + varinv(i)=varinv(i)/1.19_r_kind + if (tb_obs_sdv(2) >r1_1 .and. tb_obs_sdv(2) <=r1_3) & + varinv(i)=varinv(i)/1.25_r_kind + if (tb_obs_sdv(2) >r1_3 ) & + varinv(i)=varinv(i)/1.29_r_kind end if + if(varinv(i)>tiny_r_kind)then + errf(i) = efact*errf(i) + 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) + endif end do return -end subroutine qc_seviri +end subroutine qc_goesimg -subroutine qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & +subroutine qc_geocsr(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) + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,abi,ahi,seviri) !$$$ subprogram documentation block ! . . . -! subprogram: qc_abi QC for ABI data +! subprogram: qc_geocsr QC for CSR data from geostationary instruments ABI, AHI and SEVIRI ! ! prgmmr: H.Liu org: np23 date: 2018-05-20 ! @@ -4066,6 +4177,7 @@ subroutine qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & ! Declare passed variables + logical, intent(in ) :: abi,ahi,seviri 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 @@ -4128,7 +4240,10 @@ subroutine qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & efact=one vfact=one else if (land ) then - if (i == 2 .or. i ==3 .or. i==4 ) then + if ((abi .or. ahi) .and. (i == 2 .or. i ==3 .or. i==4) ) then + efact=one + vfact=one + else if ((seviri) .and. (i == 2 .or. i ==3) ) then efact=one vfact=one else @@ -4141,6 +4256,17 @@ subroutine qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & vfact=zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_surface_qc end if + if (seviri) then +! QC_terrain: If seviri and terrain height > 1km. do not use + if (zsges > r1000) then + efact = zero + vfact = zero + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_terrain_qc +! QC2 in statsrad + if(luse)aivals(9,is)= aivals(9,is) + one + end if + end if + ! modified variances. errf(i) = efact*errf(i) varinv(i) = vfact*varinv(i) @@ -4267,19 +4393,38 @@ subroutine qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & 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((abi .or. ahi) .and. 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 + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_std_geocsr_qc varinv(i)=zero end if end if + if(seviri .and. varinv(i) > zero) then + if(tb_obs_sdv(6)>=0.5_r_kind)then + if(i/=2) then +! QC3 in statsrad + if(luse)aivals(9,is)= aivals(9,is) + one + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_std_geocsr_qc + varinv(i)=zero + end if + end if +! QC_o-g: If abs(o-g) > 2.0 do not use + if ( i/=2 .and. abs(tbc(i)) > two ) then + varinv(i) = zero + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_gross_routine_qc +! QC1 in statsrad + if(luse)aivals(8,is)= aivals(8,is) + one !hliu check + 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( abi .and. i== 2 .or. i==3 .or. i==4 .and. varinv(i) > zero) then +! if (tb_obs_sdv(2) >0.3_r_kind .and. tb_obs_sdv(2) <=0.4_r_kind) & 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.4_r_kind .and. tb_obs_sdv(2) <=0.6_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) & @@ -4287,6 +4432,9 @@ subroutine qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & if (tb_obs_sdv(2) >0.7_r_kind ) & varinv(i)=varinv(i)/2.31_r_kind end if + if(seviri .or. ahi) then + varinv(i)=varinv(i) + end if end do ! @@ -4328,276 +4476,7 @@ subroutine qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & return -end subroutine qc_abi +end subroutine qc_geocsr -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) -! id_qc,aivals,errf,varinv,radmod) ! all-sky - -!$$$ subprogram documentation block -! . . . -! subprogram: qc_seviri QC for seviri data -! -! prgmmr: H. Liu org: np23 date: 2010-08-20 -! -! abstract: set quality control criteria for seviri data -! -! program history log: -! 2010-08-10 derber transfered from setuprad -! -! input argument list: -! nchanl - number of channels per obs -! ich - channel number -! is - integer counter for number of observation types to process -! dplat - satellite identifier -! sea - logical, sea flag -! land - logical, land flag -! ice - logical, ice flag -! snow - logical, snow flag -! luse - logical use flag -! zsges - elevation of guess -! cld - cloud percentage within averaging box -! tzbgr - surface temperature of FOV -! tb_obs - observed BT within averaging box -! tb_obs_sdv - observed BT standard deviation within averaging box -! tbc - bias corrected (observed - simulated brightness temperatures) -! tnoise - error of observed radiance -! 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) -! -! 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) -! -! 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 - real(r_kind), intent(in ) :: zsges,cld,tzbgr - real(r_kind),dimension(40,ndat), intent(inout) :: aivals - real(r_kind),dimension(nsig,nchanl),intent(in ) :: temp,wmix - real(r_kind),dimension(nchanl), intent(in ) :: tb_obs,tb_obs_sdv,tbc,tnoise,emissivity_k,ts - real(r_kind),dimension(nchanl), intent(inout) :: errf,varinv - character(10), intent(in ) :: dplat - -! Declare local parameters - - real(r_kind),parameter:: r40=40.0_r_kind - real(r_kind),parameter:: r70=70.0_r_kind - real(r_kind),parameter:: r0_3=0.3_r_kind - real(r_kind),parameter:: r0_4=0.4_r_kind - real(r_kind),parameter:: r0_6=0.6_r_kind - real(r_kind),parameter:: r0_7=0.7_r_kind - real(r_kind),parameter:: r0_8=0.8_r_kind - real(r_kind),parameter:: r0_9=0.9_r_kind - real(r_kind),parameter:: r1_1=1.1_r_kind - real(r_kind),parameter:: r1_3=1.3_r_kind - real(r_kind),parameter:: r1_4=1.4_r_kind - - - real(r_kind) :: demisf,dtempf,efact,vfact,dtbf,term,fact2,fact3,fact4,fact5 - real(r_kind) :: fact - integer(i_kind) :: i - integer(i_kind), dimension(nchanl) :: irday - real(r_kind) :: dtz,ts_ave,xindx,tzchks - - irday = 1 - - - if(tb_obs(1) > zero .and. tb_obs(2) > zero .and. tb_obs(3) > zero .and. & - tb_obs(4) > zero)then - efact = one - vfact = one - fact2 = one - fact3 = one - fact4 = one - fact5 = one - if(sea)then - demisf = r0_01 - dtempf = half - else if(land)then - do i=1,4 - if(i /= 2)then - varinv(i)=zero - if(id_qc(i) == igood_qc ) id_qc(i)=ifail_surface_qc - end if - end do - demisf = r0_01 - dtempf = two - else if(ice)then - do i=1,4 - varinv(i)=zero - if(id_qc(i) == igood_qc ) id_qc(i)=ifail_surface_qc - end do - demisf = r0_02 - dtempf = three - else if(snow)then - do i=1,4 - varinv(i)=zero - if(id_qc(i) == igood_qc ) id_qc(i)=ifail_surface_qc - end do - demisf = r0_02 - dtempf = three - else - do i=1,4 - varinv(i)=zero - if(id_qc(i) == igood_qc ) id_qc(i)=ifail_surface_qc - end do - demisf = r0_02 - dtempf = five - end if - -! Filter out data according to clear sky fraction - if(dplat == 'g10' .and. cld one ) then - varinv(1)=zero -! QC3 in statsrad - if(luse)aivals(10,is)= aivals(10,is) + one - if(id_qc(1) == igood_qc ) id_qc(1)=ifail_std_goesimg_qc - end if - - if(tb_obs_sdv(2) >1.5_r_kind ) then - varinv(2)=zero -! QC4 in statsrad - if(luse)aivals(11,is)= aivals(11,is) + one - if(id_qc(2) == igood_qc ) id_qc(2)=ifail_std_goesimg_qc - end if - - if(tb_obs_sdv(3) >one ) then - varinv(3)=zero -! QC5 in statsrad - if(luse)aivals(12,is)= aivals(12,is) + one - if(id_qc(3) == igood_qc ) id_qc(3)=ifail_std_goesimg_qc - end if - - if(tb_obs_sdv(4) >one ) then - varinv(4)=zero -! QC6 in statsrad - if(luse)aivals(13,is)= aivals(13,is) + one - if(id_qc(4) == igood_qc ) id_qc(4)=ifail_std_goesimg_qc - end if - -! Reduce weight for obs over higher topography - if (zsges > r2000) then - fact = r2000/zsges - efact = fact - vfact = fact*vfact -! QC2 in statsrad - if(luse)aivals(9,is)= aivals(9,is) + one - end if - else - vfact=zero - end if -! -! 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 - endif - -! Generate q.c. bounds and modified variances. - do i=1,nchanl - varinv(i) = vfact*varinv(i) - if( dplat == 'g10' .and. i== 2) then - if (tb_obs_sdv(2) >r0_3 .and. tb_obs_sdv(2) <=r0_6) & - varinv(i)=varinv(i)/1.05_r_kind - if (tb_obs_sdv(2) >r0_6 .and. tb_obs_sdv(2) <=r0_7) & - varinv(i)=varinv(i)/1.15_r_kind - if (tb_obs_sdv(2) >r0_7 .and. tb_obs_sdv(2) <=r0_8) & - varinv(i)=varinv(i)/1.24_r_kind - if (tb_obs_sdv(2) >r0_8 .and. tb_obs_sdv(2) <=r0_9) & - varinv(i)=varinv(i)/1.28_r_kind - if (tb_obs_sdv(2) >r0_9 .and. tb_obs_sdv(2) <=one) & - varinv(i)=varinv(i)/1.32_r_kind - if (tb_obs_sdv(2) >one .and. tb_obs_sdv(2) <=r1_1) & - varinv(i)=varinv(i)/1.35_r_kind - if (tb_obs_sdv(2) >r1_1 .and. tb_obs_sdv(2) <=r1_3) & - varinv(i)=varinv(i)/1.39_r_kind - if (tb_obs_sdv(2) >r1_4 ) & - varinv(i)=varinv(i)/1.48_r_kind - else if(dplat == 'g12' .and. i== 2) then - if (tb_obs_sdv(2) >r0_4 .and. tb_obs_sdv(2) <=half) & - varinv(i)=varinv(i)/1.05_r_kind - if (tb_obs_sdv(2) >half .and. tb_obs_sdv(2) <=r0_6) & - varinv(i)=varinv(i)/1.09_r_kind - if (tb_obs_sdv(2) >r0_6 .and. tb_obs_sdv(2) <=r0_7) & - varinv(i)=varinv(i)/1.14_r_kind - if (tb_obs_sdv(2) >r0_7 .and. tb_obs_sdv(2) <=r0_8) & - varinv(i)=varinv(i)/1.17_r_kind - if (tb_obs_sdv(2) >r0_8 .and. tb_obs_sdv(2) <=r1_1) & - varinv(i)=varinv(i)/1.19_r_kind - if (tb_obs_sdv(2) >r1_1 .and. tb_obs_sdv(2) <=r1_3) & - varinv(i)=varinv(i)/1.25_r_kind - if (tb_obs_sdv(2) >r1_3 ) & - varinv(i)=varinv(i)/1.29_r_kind - end if - if(varinv(i)>tiny_r_kind)then - errf(i) = efact*errf(i) - 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) - endif - end do - - return - -end subroutine qc_goesimg end module qcmod diff --git a/src/gsi/radiance_mod.f90 b/src/gsi/radiance_mod.f90 index 9b677730f3..527cc62bcf 100644 --- a/src/gsi/radiance_mod.f90 +++ b/src/gsi/radiance_mod.f90 @@ -337,7 +337,7 @@ subroutine radiance_obstype_init 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 + use chemmod, only: laeroana_gocart implicit none logical :: first,diffistr,found @@ -411,7 +411,7 @@ subroutine radiance_obstype_init 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 + rtype(i) == 'cris-fsr' .or. rtype(i) == 'abi' ) then drtype(i)='rads' end if end do diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90 index 83f69e3077..907db4643d 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -55,6 +55,7 @@ module radinfo ! 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. +! 2019-08-20 zhu - add flexibility to allow radiances being assimilated without bias correction ! ! subroutines included: ! sub init_rad - set satellite related variables to defaults @@ -697,7 +698,7 @@ subroutine radinfo_read allocate(nuchan(jpch_rad),nusis(jpch_rad),iuse_rad(0:jpch_rad), & 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),& + ang_rad(jpch_rad),air_rad(jpch_rad),inew_rad(jpch_rad), & icld_det(jpch_rad),icloud4crtm(jpch_rad),iaerosol4crtm(jpch_rad), & iextra_det(jpch_rad), & isnow_det(jpch_rad), & @@ -847,7 +848,8 @@ subroutine radinfo_read varA(i,j)=varx(i) end do ostats(j)=ostatsx - if (any(varx/=zero) .and. iuse_rad(j)>-2) inew_rad(j)=.false. + if ((any(varx/=zero) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) & + inew_rad(j)=.false. cycle read3 end if end do @@ -1078,7 +1080,11 @@ subroutine radinfo_read cfound = .true. nfound(j) = .true. do i=1,npred - predx(i,j)=predr(i) + if (iuse_rad(j)==4) then + predx(i,j)=zero + else + predx(i,j)=predr(i) + end if end do if (adp_anglebc) then tlapmean(j)=tlapm @@ -1086,7 +1092,7 @@ subroutine radinfo_read count_tlapmean(j)=ntlapupdate if (ntlapupdate > ntlapthresh) update_tlapmean(j)=.false. end if - if (any(predr/=zero)) inew_rad(j)=.false. + if (any(predr/=zero) .or. iuse_rad(j)==4) inew_rad(j)=.false. cycle read4 end if end do @@ -1129,13 +1135,15 @@ subroutine radinfo_read ! Initialize predx if inew_rad and compute angle bias correction and tlapmean if (adp_anglebc) then call init_predx + cbias=zero do j=1,jpch_rad + if (iuse_rad(j)==4) cycle call angle_cbias(nusis(j),j,cbias(1,j)) end do ! check inew_rad again do j =1,jpch_rad - if (inew_rad(j) .and. iuse_rad(j)>=0 .and. all(predx(:,j)==zero)) then + if (inew_rad(j) .and. iuse_rad(j)>=0 .and. iuse_rad(j)/=4 .and. all(predx(:,j)==zero)) then iuse_rad(j)=-1 end if end do diff --git a/src/gsi/read_abi.f90 b/src/gsi/read_abi.f90 index 465d7f22a0..3a50f65b51 100644 --- a/src/gsi/read_abi.f90 +++ b/src/gsi/read_abi.f90 @@ -47,11 +47,13 @@ subroutine read_abi(mype,val_abi,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,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 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 @@ -94,7 +96,7 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& 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 @@ -111,6 +113,8 @@ subroutine read_abi(mype,val_abi,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 logical :: allchnmiss @@ -190,8 +194,14 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& return 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 BUFR string based on abi data set hdrabi='SAID YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH SAZA BEARAZ SOZA SOLAZI' @@ -225,6 +235,7 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& open(lnbufr,file=infile,form='unformatted') call openbf(lnbufr,'IN',lnbufr) if(jsatid == 'gr' .or. jsatid == 'g16') kidsat = 270 + if(jsatid == 'g17') kidsat = 271 nrec=999999 @@ -303,14 +314,11 @@ subroutine read_abi(mype,val_abi,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 + 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 @@ -327,7 +335,8 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& end if else if(allsky) then call ufbrep(lnbufr,dataabi1,1,2,iret,'NCLDMNT') - rclrsky=dataabi1(1,2) !clear-sky percentage over sea + rclrsky=dataabi1(1,1) !clear-sky percentage +! 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 @@ -336,11 +345,13 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& 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 + if(clrsky) then + 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 + end if allchnmiss=.true. do n=1,nchn @@ -379,9 +390,13 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& ! 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 + if(clrsky) then +! use NCLDMNT from chn7 (10.8 micron) as a QC predictor +! add SDTB from chn7 as QC predictor + pred=10.0_r_kind-dataabi1(1,7)/10.0_r_kind+dataabi3(1,7)*10.0_r_kind + else + pred=zero + end if ! ! Compute "score" for observation. All scores>=0.0. Lowest score is "best" @@ -444,7 +459,7 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& if(clrsky) then data_all(32+k,itx) = dataabi3(1,k) ! BT standard deviation from ABICSR else if(allsky) then - jj=k*6+1 + jj=(k-1)*6+1 data_all(32+k,itx) = dataabi3(1,jj) ! BT standard deviation from ABIASR end if end do @@ -465,7 +480,7 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& 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 + jj=(k-1)*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 diff --git a/src/gsi/read_aerosol.f90 b/src/gsi/read_aerosol.f90 index 67e6ab8e5f..abfc115a29 100644 --- a/src/gsi/read_aerosol.f90 +++ b/src/gsi/read_aerosol.f90 @@ -164,7 +164,6 @@ subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, & 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 diff --git a/src/gsi/read_ahi.f90 b/src/gsi/read_ahi.f90 index b7f8ee3aea..3237f2e6fc 100644 --- a/src/gsi/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,dval_use) + mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs,nrec_start,dval_use) !$$$ subprogram documentation block ! . . . . ! subprogram: read_ahi read himawari-8 ahi data @@ -35,6 +35,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& ! 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 GOES imager observations read @@ -54,6 +55,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& 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 obsmod, only: bmiss use radinfo, only: iuse_rad,jpch_rad,nusis use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar use deter_sfc_mod, only: deter_sfc @@ -61,13 +63,12 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter use file_utility, only : get_lun use mpimod, only: npe -! use radiance_mod, only: rad_obs_type implicit none ! Declare passed variables character(len=*),intent(in ) :: infile,obstype,jsatid character(len=*),intent(in ) :: sis - integer(i_kind) ,intent(in ) :: mype,lunout,ithin + integer(i_kind) ,intent(in ) :: mype,lunout,ithin,nrec_start integer(i_kind),dimension(npe) ,intent(inout) :: nobs integer(i_kind) ,intent(inout) :: ndata,nodata integer(i_kind) ,intent(inout) :: nread @@ -80,21 +81,20 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& logical ,intent(in) :: dval_use ! Declare local parameters - integer(i_kind),parameter:: nimghdr=13 - integer(i_kind),parameter:: maxchanl=11 + integer(i_kind),parameter:: nimghdr=11 real(r_kind),parameter:: r360=360.0_r_kind real(r_kind),parameter:: r180=180.0_r_kind real(r_kind),parameter:: tbmin=50.0_r_kind real(r_kind),parameter:: tbmax=550.0_r_kind character(80),parameter:: hdrh8 = & ! Himawari-8 AHI header - 'SAID YEAR MNTH DAYS HOUR MINU SECW CLATH CLONH SAZA SOZA BEARAZ SOLAZI' + 'SAID YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH SAZA SOZA' ! Declare local variables logical outside,iuse,assim character(8) subset - integer(i_kind) nchanl,ilath,ilonh,ilzah,iszah,irec,next,maxinfo + integer(i_kind) nchanl,ilath,ilonh,ilzah,iszah,irec,next,maxinfo,nchn 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 @@ -112,8 +112,11 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& real(r_kind) :: zob,tref,dtw,dtc,tz_tr real(r_kind),allocatable,dimension(:,:):: data_all + logical :: allchnmiss + real(r_kind) rclrsky,rcldfrc real(r_double),dimension(nimghdr) :: hdrh8arr ! Himawari8 AHI data - real(r_double),dimension(3,12) :: dataahi ! Himawari8 AHI data + real(r_double),allocatable,dimension(:,:) :: dataahi,dataahibt,dataahisd ! Himawari8 AHI data for NCLDMNT,BT,SDTB + real(r_kind),dimension(0:4):: rlndsea !--start-- variables for AHI cloud detection real(r_kind) :: ts_coef0 @@ -129,7 +132,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& real(r_kind) :: sst_test !-end--- variables for AHI cloud detection - real(r_kind) disterr,disterrmax,dlon00,dlat00 + 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 @@ -148,9 +151,18 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& call gsi_nstcoupler_skindepth(obstype, zob) ! get penetration depth (zob) for the obstype endif + 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 ! the channel number + + nchn=12 ! total numer of channels + nchanl=10 ! total number of channels with valid BT and SDTB ilath=8 ! the position of latitude in the header ilonh=9 ! the position of longitude in the header ilzah=10 ! satellite zenith angle @@ -185,16 +197,32 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& open(lnbufr,file=trim(infile),form='unformatted') call openbf(lnbufr,'IN',lnbufr) call datelen(10) - if(jsatid == 'himawari8') kidsat = 173 + call readmg(lnbufr,subset,idate,iret) -! Allocate arrays to hold all data for given satellite +! Check the data set + if( iret/=0) then + write(6,*) 'READ_AHI: SKIP PROCESSING OF AHI FILE' + write(6,*) 'infile=', lnbufr, infile + return + endif + + allocate(dataahi(1,nchn)) ! NCLDMNT: 2 for ASR, not channel dependent; ncld for CSR, chn dependent + allocate(dataahibt(1,nchn)) ! BT: channel dependent: all, clear, cloudy, low, middle and high clouds + allocate(dataahisd(1,nchn)) ! SDTB: channel dependent: all, clear, cloudy, low, middle and high clouds - maxinfo=31 +! Allocate arrays to hold all data for given satellite + maxinfo=32 + maxinfo=maxinfo+nchanl if(dval_use) maxinfo = maxinfo + 2 nreal = maxinfo + nstinfo nele = nreal + nchanl allocate(data_all(nele,itxmax),nrec(itxmax)) + call closbf(lnbufr) + open(lnbufr,file=trim(infile),form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + if(jsatid == 'himawari8') kidsat = 173 + next=0 nrec=999999 irec=0 @@ -205,7 +233,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& 2.16380_r_kind/) ts_coef0 = -51.0104_r_kind !---should be channels 11.2 and 12.38 microns - ts_ichan = (/10,11/) ! (8,9) offset by two for bands 5 and 6 of AHI + ts_ichan = (/7,8/) !---threshold for difference in regression from tsavg ! COAT used 1.25 so we may need to make this smaller. dts_thresh = 2.00 @@ -213,8 +241,9 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& qc_thresh = -1 ! Big loop over bufr file - do while(IREADMG(lnbufr,subset,idate) >= 0) + 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 @@ -223,29 +252,24 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& ! Read through each reacord call ufbint(lnbufr,hdrh8arr,nimghdr,1,iret,hdrh8) if(hdrh8arr(1) /= kidsat) cycle read_loop - call ufbrep(lnbufr,dataahi,3,12,iret,'TMBR CHNM CHWL') + +! only the first 10 chns are valid + call ufbrep(lnbufr,dataahibt,1,nchn,iret,'TMBRST') nread=nread+nchanl -! first step QC filter out data with less clear sky fraction - if (hdrh8arr(ilzah) >r60) cycle read_loop - if (hdrh8arr(iszah) >= r180) cycle read_loop + allchnmiss=.true. + do n=1,nchanl + if(dataahibt(1,n)<500.0_r_kind) then + allchnmiss=.false. + end if + end do + if(allchnmiss) cycle read_loop -! Compare relative obs time with window. If obs -! falls outside of window, don't use this obs - idate5(1) = hdrh8arr(2) !year - idate5(2) = hdrh8arr(3) ! month - idate5(3) = hdrh8arr(4) ! day - idate5(4) = hdrh8arr(5) ! hours - idate5(5) = hdrh8arr(6) ! minutes - call w3fs21(idate5,nmind) - t4dv = (real((nmind-iwinbgn),r_kind) + real(hdrh8arr(7),r_kind)*r60inv)*r60inv - sstime = real(nmind,r_kind) + real(hdrh8arr(7),r_kind)*r60inv - tdiff=(sstime-gstime)*r60inv - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) cycle read_loop - else - if (abs(tdiff)>twind) cycle read_loop - endif +! first step QC filter out data with SAZA>60degree,check use 60 or 65 + if (hdrh8arr(ilzah) >65.0_r_kind .or. hdrh8arr(iszah) >= r180) then + print*, 'SAZA & Satellite azimuth',hdrh8arr(ilzah),hdrh8arr(iszah) + cycle read_loop + end if ! Convert obs location from degrees to radians if (hdrh8arr(ilonh)>=r360) hdrh8arr(ilonh)=hdrh8arr(ilonh)-r360 @@ -266,8 +290,10 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& if(diagnostic_reg) then call txy2ll(dlon,dlat,dlon00,dlat00) ntest=ntest+1 - disterr=acos(sin(dlat_earth)*sin(dlat00)+cos(dlat_earth)*cos(dlat00)* & - (sin(dlon_earth)*sin(dlon00)+cos(dlon_earth)*cos(dlon00)))*rad2deg + 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 @@ -283,12 +309,51 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& 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) = hdrh8arr(2) !year + idate5(2) = hdrh8arr(3) ! month + idate5(3) = hdrh8arr(4) ! day + idate5(4) = hdrh8arr(5) ! hours + idate5(5) = hdrh8arr(6) ! minutes + call w3fs21(idate5,nmind) + t4dv = (real((nmind-iwinbgn),r_kind) + real(hdrh8arr(7),r_kind)*r60inv)*r60inv + sstime = real(nmind,r_kind) + real(hdrh8arr(7),r_kind)*r60inv + tdiff=(sstime-gstime)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle read_loop + else + if (abs(tdiff)>twind) cycle read_loop + endif + 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 + rclrsky=bmiss + rcldfrc=bmiss + + call ufbrep(lnbufr,dataahi,1,nchn,iret,'NCLDMNT') +! dataahi(1,2) is high-peaking water vapor channel +! for AHI CSR, clear-sky percentage are the same for all the channels + if(dataahi(1,2)>= zero .and. dataahi(1,2) <= 100.0_r_kind ) then + rclrsky=dataahi(1,2) +! first QC filter out data with less clear sky fraction + if ( rclrsky < 70.0_r_kind ) cycle read_loop + end if + + call ufbrep(lnbufr,dataahisd,1,nchn,iret,'SDTB') + +! toss data if SDTB>1.3 + do i=1,nchanl + if(i==2 .or. i==3 .or. i==4) then ! 3 water-vapor channels + if(dataahisd(1,i)>1.3_r_kind) then + cycle read_loop + end if + end if + end do ! Locate the observation on the analysis grid. Get sst and land/sea/ice ! mask. @@ -304,7 +369,7 @@ subroutine read_ahi(mype,val_img,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) - if (isflg >= 1) cycle read_loop !!!test ocean only +! if (isflg >= 1) cycle read_loop !!!test ocean only ! Set common predictor parameters @@ -314,7 +379,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& !---secant of the sensor zenith angle seca = 1.0_r_kind / COS( hdrh8arr(ilzah) * deg2rad ) !---brightness temperature of channels used for regression - bt_ts = dataahi(1,ts_ichan) + bt_ts = dataahibt(1,ts_ichan) !---difference in BTs water-window or window-water ! (depends on channel selection) @@ -338,7 +403,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& ! with delta.ts > dts_threshold ! tsavg from deter_sfc sst_test = tsavg-ts_reg - if (abs(sst_test) >= dts_thresh) cycle read_loop +! if (abs(sst_test) >= dts_thresh) cycle read_loop !---Option 2.) !---or we can do this --use sathin module to select best pixels @@ -349,11 +414,17 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& sst_test = ABS(sst_test) pred = 15._r_kind*sst_test - crit1 = crit1 + pred !end by ZZMA + + crit1=crit1+rlndsea(isflg) call checkob(dist1,crit1,itx,iuse) if(.not. iuse)cycle read_loop +! use NCLDMNT from chn7 (10.8 micron) as a QC predictor +! add SDTB from chn7 as QC predictor + pred=10.0_r_kind-dataahi(1,7)/10.0_r_kind+dataahisd(1,7)*10.0_r_kind + + crit1 = crit1 + pred ! Compute "score" for observation. All scores>=0.0. Lowest score is "best" call finalcheck(dist1,crit1,itx,iuse) if(.not. iuse) cycle read_loop @@ -379,11 +450,11 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& data_all( 3,itx) = dlon ! grid relative longitude data_all( 4,itx) = dlat ! grid relative latitude data_all( 5,itx) = hdrh8arr(ilzah)*deg2rad ! satellite zenith angle (radians) - data_all( 6,itx) = hdrh8arr(12) ! satellite azimuth angle (radians) -!ZZ data_all( 7,itx) = dataahi(2,1) ! clear sky amount + data_all( 6,itx) = bmiss ! satellite azimuth angle (radians) + data_all( 7,itx) = rclrsky ! clear sky amount data_all( 8,itx) = iscan ! integer scan position data_all( 9,itx) = hdrh8arr(iszah) ! solar zenith angle - data_all(10,itx) = hdrh8arr(13) ! solar azimuth angle + data_all(10,itx) = bmiss ! 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 @@ -405,6 +476,10 @@ 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) = rcldfrc ! total cloud fraction from AHIASR + do k=1,nchanl + data_all(32+k,itx) = dataahisd(1,k) ! BT standard deviation from AHICSR + end do if(dval_use)then data_all(maxinfo-1,itx) = val_img @@ -421,13 +496,14 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& ! Transfer observation location and other data to local arrays do k=1,nchanl - data_all(k+nreal,itx)=dataahi(1,k+2) ! test only for AHI channels:7-16 + data_all(k+nreal,itx)=dataahibt(1,k) ! test only for AHI channels:7-16 end do nrec(itx)=irec enddo read_loop - enddo + 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) @@ -455,11 +531,10 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& ! Deallocate local arrays deallocate(data_all,nrec) + deallocate(dataahi,dataahibt,dataahisd) ! Deallocate satthin arrays -900 continue call destroygrids - call closbf(lnbufr) if(diagnostic_reg.and.ntest>0) write(6,*)'READ_AHI: ',& 'mype,ntest,disterrmax=',mype,ntest,disterrmax diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index 0964db2487..df2612a420 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -402,7 +402,6 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ! inflate selection value for ears_db data 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) diff --git a/src/gsi/read_cris.f90 b/src/gsi/read_cris.f90 index 5fbf49d8ca..91bac38c65 100644 --- a/src/gsi/read_cris.f90 +++ b/src/gsi/read_cris.f90 @@ -650,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 @@ -659,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 @@ -700,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 @@ -733,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_netcdf.f90 b/src/gsi/read_dbz_netcdf.f90 index 994680451e..6ea03afaff 100644 --- a/src/gsi/read_dbz_netcdf.f90 +++ b/src/gsi/read_dbz_netcdf.f90 @@ -117,7 +117,6 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob ! !$$$ 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 diff --git a/src/gsi/read_files.f90 b/src/gsi/read_files.f90 index 5722ede1ad..3b2ad73371 100644 --- a/src/gsi/read_files.f90 +++ b/src/gsi/read_files.f90 @@ -37,6 +37,7 @@ subroutine read_files(mype) ! 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 +! 2019-09-24 martin - add support for use_gfs_ncio ! ! input argument list: ! mype - mpi task id @@ -82,7 +83,7 @@ subroutine read_files(mype) 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 + use gridmod, only: nlat_sfc,nlon_sfc,lpl_gfs,dx_gfs,use_gfs_nemsio,sfcnst_comb,use_gfs_ncio use constants, only: zero,r60inv,r60,r3600,i_missing use obsmod, only: iadate use gsi_nstcouplermod, only: nst_gsi @@ -96,6 +97,9 @@ 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 module_fv3gfs_ncio, only: Dataset, Dimension, open_dataset, get_dim, & + read_vardata, get_idate_from_time_units, & + close_dataset use chemmod, only: lread_ext_aerosol implicit none @@ -122,12 +126,14 @@ subroutine read_files(mype) integer(i_kind),dimension(2):: i_ges integer(i_kind),allocatable,dimension(:):: nst_ges integer(i_kind),dimension(5):: idate5 + integer(i_kind),dimension(6):: idate6 integer(i_kind),dimension(num_lpl):: lpl_dum integer(i_kind),dimension(7):: idate integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd integer(i_kind),dimension(:,:),allocatable:: irec integer(i_llong) :: lenbytes real(r_single) hourg4 + real(r_kind), allocatable, dimension(:) :: fhour real(r_kind) hourg,t4dv real(r_kind),allocatable,dimension(:,:):: time_atm real(r_kind),allocatable,dimension(:,:):: time_sfc @@ -139,6 +145,8 @@ subroutine read_files(mype) type(nstio_head):: nst_head type(nemsio_gfile) :: gfile_atm,gfile_sfc,gfile_nst,gfile_aer logical :: print_verbose + type(Dataset) :: atmges, sfcges, nstges + type(Dimension) :: ncdim print_verbose=.false. @@ -223,12 +231,22 @@ subroutine read_files(mype) do i=1,nfldsig write(filename,'(''sigf'',i2.2)')irec(i,1) if(print_verbose)write(6,*)'READ_FILES: process ',trim(filename) - if ( .not. use_gfs_nemsio ) then + if ( (.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio) ) then call sigio_sropen(lunatm,filename,iret) call sigio_srhead(lunatm,sigatm_head,iret) hourg4=sigatm_head%fhour idateg=sigatm_head%idate call sigio_sclose(lunatm,iret) + else if (use_gfs_ncio) then + atmges = open_dataset(filename) + idate6 = get_idate_from_time_units(atmges) + call read_vardata(atmges, 'time', fhour) + hourg4 = float(nint(fhour(1))) ! going to make this nearest integer for now + idateg(1) = idate6(4) + idateg(2) = idate6(2) + idateg(3) = idate6(3) + idateg(4) = idate6(1) + call close_dataset(atmges) else call nemsio_init(iret=iret) call nemsio_open(gfile_atm,filename,'READ',iret=iret) @@ -278,7 +296,7 @@ subroutine read_files(mype) do i=1,nfldsfc write(filename,'(''sfcf'',i2.2)')irec(i,2) if(print_verbose)write(6,*)'READ_FILES: process ',trim(filename) - if ( .not. use_gfs_nemsio ) then + if ( (.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio) ) then call sfcio_sropen(lunsfc,filename,iret) call sfcio_srhead(lunsfc,sfc_head,iret) hourg4=sfc_head%fhour @@ -293,6 +311,34 @@ subroutine read_files(mype) lpl_dum(1:sfc_head%latb/2)=sfc_head%lpl call sfcio_sclose(lunsfc,iret) if(i == 1 .and. print_verbose)write(6,*)' READ_FILES: in sfcio sfc_head%lpl = ', sfc_head%lpl + else if (use_gfs_ncio) then + sfcges = open_dataset(filename) + ncdim = get_dim(sfcges, 'grid_xt'); sfc_head%lonb = ncdim%len + ncdim = get_dim(sfcges, 'grid_yt'); sfc_head%latb = ncdim%len + idate6 = get_idate_from_time_units(sfcges) + call read_vardata(sfcges, 'time', fhour) + hourg4 = float(nint(fhour(1))) ! going to make this nearest integer for now + idateg(1) = idate6(4) + idateg(2) = idate6(2) + idateg(3) = idate6(3) + idateg(4) = idate6(1) + i_ges(1)=sfc_head%lonb + i_ges(2)=sfc_head%latb+2 + if((sfc_head%latb+1)/2>num_lpl)then + write(6,*)'READ_FILES: increase dimension of variable lpl_dum' + call stop2(80) + endif + if ( (sfc_head%latb+1)/2 /= sfc_head%latb/2 ) then + write(6,*) 'READ_FILES: ****WARNING**** (sfc_head%latb+1)/2 = ', & + (sfc_head%latb+1)/2, 'sfc_head%latb/2 = ', sfc_head%latb/2 + end if + if (allocated(sfc_head%lpl)) deallocate(sfc_head%lpl) + allocate(sfc_head%lpl((sfc_head%latb+1)/2)) + sfc_head%lpl=sfc_head%lonb + call close_dataset(sfcges) + lpl_dum=0 + lpl_dum(1:sfc_head%latb/2)=sfc_head%lpl + deallocate(sfc_head%lpl) else call nemsio_init(iret=iret) call nemsio_open(gfile_sfc,filename,'READ',iret=iret) @@ -371,13 +417,24 @@ subroutine read_files(mype) do i=1,nfldnst write(filename,'(''nstf'',i2.2)')irec(i,3) write(6,*)'READ_FILES: process ',trim(filename) - if ( .not. use_gfs_nemsio ) then + if ( (.not. use_gfs_nemsio) .and. (.not. use_gfs_ncio) ) then call nstio_sropen(lunnst,filename,iret) call nstio_srhead(lunnst,nst_head,iret) hourg4=nst_head%fhour idateg=nst_head%idate nst_ges(1)=nst_head%lonb nst_ges(2)=nst_head%latb+2 + else if (use_gfs_ncio) then + nstges = open_dataset(filename) + ncdim = get_dim(nstges, 'grid_xt'); nst_head%lonb = ncdim%len + ncdim = get_dim(nstges, 'grid_yt'); nst_head%latb = ncdim%len + idate6 = get_idate_from_time_units(nstges) + call read_vardata(nstges, 'time', fhour) + hourg4 = fhour(1) + idateg(1) = idate6(4) + idateg(2) = idate6(2) + idateg(3) = idate6(3) + idateg(4) = idate6(1) else call nemsio_init(iret=iret) call nemsio_open(gfile_nst,filename,'READ',iret=iret) diff --git a/src/gsi/read_fl_hdob.f90 b/src/gsi/read_fl_hdob.f90 index 83c7a82c25..93330c925f 100644 --- a/src/gsi/read_fl_hdob.f90 +++ b/src/gsi/read_fl_hdob.f90 @@ -241,7 +241,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si iecol = 2 errmin = half ! set lower bound of ob error for T or Tv else if (luvob) then - nreal = 25 + nreal = 26 iecol = 4 errmin = one ! set lower bound of ob error for u,v winds else if (lspdob) then @@ -1035,6 +1035,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name cdata_all(24,iout)=qcm ! cat cdata_all(25,iout)=var_jb ! non linear qc + cdata_all(26,iout)=one if(perturb_obs)then cdata_all(26,iout)=ran01dom()*perturb_fact ! u perturbation cdata_all(27,iout)=ran01dom()*perturb_fact ! v perturbation diff --git a/src/gsi/read_gps.f90 b/src/gsi/read_gps.f90 index 8951a9a0aa..860b3e3cfd 100644 --- a/src/gsi/read_gps.f90 +++ b/src/gsi/read_gps.f90 @@ -257,7 +257,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & ! Check profile quality flags if ( ((said > 739).and.(said < 746)).or.(said == 820).or.(said == 786).or.& - (said == 825)) then !CDAAC processing + ((said > 749).and.(said < 756)).or.(said == 825).or.(said == 44) ) then !CDAAC processing if(pcc==zero) then ! write(6,*)'READ_GPS: bad profile said=',said,'ptid=',ptid,& ! ' SKIP this report' @@ -266,7 +266,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & endif if ((said == 4).or.(said == 3).or.(said == 421).or.(said == 440).or.& - (said == 821)) then ! GRAS SAF processing + (said == 821).or.(said == 5)) then ! GRAS SAF processing call upftbv(lnbufr,nemo,qfro,mxib,ibit,nib) lone = .false. if(nib > 0) then diff --git a/src/gsi/read_guess.F90 b/src/gsi/read_guess.F90 index e42f01a36b..608bfc56e8 100644 --- a/src/gsi/read_guess.F90 +++ b/src/gsi/read_guess.F90 @@ -73,6 +73,8 @@ subroutine read_guess(iyear,month,idd,mype) ! 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 +! 2019-09-18 martin - added new fields to save guess tsen, q, geop_hgt for writing increment +! 2019-09-23 martin - add code for FV3 GFS netcdf guess input ! ! input argument list: ! mype - mpi task id @@ -87,8 +89,8 @@ 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 guess_grids, only: nfldsig,ges_tsen,load_prsges,load_geop_hgt,ges_prsl,& + ges_tsen1, geop_hgti, ges_geopi, ges_q1 use m_gsiBiases,only : bkg_bias_correction,nbc use m_gsiBiases, only: gsi_bkgbias_bundle use gsi_bias, only: read_bias @@ -97,12 +99,13 @@ subroutine read_guess(iyear,month,idd,mype) 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 gridmod, only: use_gfs_nemsio, use_gfs_ncio, write_fv3_incr use gfs_stratosphere, only: use_gfs_stratosphere use constants, only: zero,one,fv,qmin use ncepgfs_io, only: read_gfs,read_gfs_chem use ncepnems_io, only: read_nems,read_nems_chem + use netcdfgfs_io, only: read_gfsnc, read_gfsnc_chem use gsi_metguess_mod, only: gsi_metguess_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsd_update_mod, only: gsd_gen_coast_prox @@ -110,7 +113,7 @@ subroutine read_guess(iyear,month,idd,mype) 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 + use mpimod, only: mpi_comm_world implicit none @@ -185,6 +188,9 @@ subroutine read_guess(iyear,month,idd,mype) !! WRITE(6,*)'WARNING :: you elect to read first guess field in NEMSIO format' call read_nems call read_nems_chem(iyear,month,idd) + else if ( use_gfs_ncio ) then + call read_gfsnc + call read_gfsnc_chem(iyear,month,idd) else call read_gfs call read_gfs_chem(iyear,month,idd) @@ -212,15 +218,18 @@ subroutine read_guess(iyear,month,idd,mype) do i=1,lat2 ! ges_tsen(i,j,k,it)= ges_tv(i,j,k)/(one+fv*max(qmin,ges_q(i,j,k))) ges_tsen(i,j,k,it)= ges_tv(i,j,k)/(one+fv*max(zero,ges_q(i,j,k))) + if (write_fv3_incr) ges_q1(i,j,k,it) = max(zero, ges_q(i,j,k)) end do end do end do end if end do + ! Load 3d subdomain pressure arrays from the guess fields call load_prsges + ! recompute sensible temperature to remove supersaturation if ( clip_supersaturation ) then call tpause(mype,'pvoz') @@ -243,6 +252,7 @@ subroutine read_guess(iyear,month,idd,mype) end do end do end do + if (write_fv3_incr) ges_q1(:,:,:,it) = ges_q(i,j,k) end do endif ! clip_supersaturation @@ -250,9 +260,12 @@ 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 +! save guess geopotential height at level interface for use in write_atm ges_geopi=geop_hgti +! save this for writing increment + ges_tsen1(:,:,:,:) = ges_tsen(:,:,:,:) + ! Compute the coast proximity call gsd_gen_coast_prox diff --git a/src/gsi/read_nsstbufr.f90 b/src/gsi/read_nsstbufr.f90 index b13f32a2a4..31435280dc 100644 --- a/src/gsi/read_nsstbufr.f90 +++ b/src/gsi/read_nsstbufr.f90 @@ -328,31 +328,31 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & zob = ship%depth(n) if ( trim(ship%sensor(n)) == 'BU' ) then kx = 181 - sstoe = r1_5 + sstoe = 0.75_r_kind elseif ( trim(ship%sensor(n)) == 'C' ) then kx = 182 - sstoe = two + sstoe = one elseif ( trim(ship%sensor(n)) == 'HC' ) then kx = 183 - sstoe = two + sstoe = one elseif ( trim(ship%sensor(n)) == 'BTT' ) then kx = 184 - sstoe = two + sstoe = one elseif ( trim(ship%sensor(n)) == 'HT' ) then kx = 185 - sstoe = two + sstoe = one elseif ( trim(ship%sensor(n)) == 'RAD' ) then kx = 186 - sstoe = two + sstoe = one elseif ( trim(ship%sensor(n)) == 'TT' ) then kx = 187 - sstoe = two + sstoe = one elseif ( trim(ship%sensor(n)) == 'OT' ) then kx = 188 - sstoe = two + sstoe = one else kx = 189 - sstoe = three + sstoe = two endif endif enddo @@ -360,16 +360,16 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & if ( ship_mod == 0 ) then if ( msst == two ) then ! positive or zero bucket kx = 181 - sstoe = two + sstoe = 0.75_r_kind zob = one elseif ( msst == zero .or. msst == one ) then ! positive/negative/zero intake kx = 182 - sstoe = 2.5_r_kind + sstoe = one zob = three else kx = 189 + sstoe = two zob = 2.5_r_kind - sstoe = three endif endif @@ -388,20 +388,20 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & zob = r1_2 kx = 192 - sstoe = half + sstoe = 0.75_r_kind elseif ( cid_pos > n_scripps .and. cid_pos <= n_triton ) then ! Triton buoy zob = r1_5 kx = 194 - sstoe = 0.4_r_kind + sstoe = half elseif ( cid_pos == 0 ) then zob = r0_2 if ( cid(3:3) == '5' .or. cid(3:3) == '6' .or. cid(3:3) == '7' .or. cid(3:3) == '8' .or. cid(3:3) == '9' ) then kx = 190 - sstoe = r0_6 + sstoe = half elseif ( cid(3:3) == '0' .or. cid(3:3) == '1' .or. cid(3:3) == '2' .or. cid(3:3) == '3' .or. cid(3:3) == '4') then kx = 191 sstoe = half @@ -412,7 +412,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & elseif ( trim(subset) == 'NC001102' ) then ! DBUOYB zob = r0_2 kx = 190 - sstoe = r0_6 + sstoe = half elseif ( trim(subset) == 'NC001003' ) then ! MBUOY cid_pos = 0 @@ -426,23 +426,23 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & if ( cid_pos >= 1 .and. cid_pos <= n_comps ) then ! COMPS moored buoy zob = r1_2 kx = 192 - sstoe = one + sstoe = 0.75_r_kind elseif ( cid_pos > n_comps .and. cid_pos <= n_scripps ) then ! SCRIPPS moored buoy zob = r0_45 kx = 193 - sstoe = 1.5_r_kind + sstoe = 0.75_r_kind elseif ( cid_pos > n_scripps .and. cid_pos <= n_triton ) then ! Triton buoy zob = r1_5 kx = 194 - sstoe = 0.4_r_kind + sstoe = half elseif ( cid_pos > n_triton .and. cid_pos <= n_3mdiscus ) then ! Moored buoy with 3-m discus zob = r0_6 kx = 195 - sstoe = 1.5_r_kind + sstoe = 0.75_r_kind elseif ( cid_pos == 0 ) then ! All other moored buoys (usually with 1-m observation depth) zob = one kx = 196 - sstoe = one + sstoe = 0.75_r_kind endif elseif ( trim(subset) == 'NC001103' ) then ! MBUOYB @@ -458,29 +458,30 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & if ( cid_pos >= 1 .and. cid_pos <= n_comps ) then ! COMPS moored buoyb zob = r1_2 kx = 192 - sstoe = one + sstoe = 0.75_r_kind elseif ( cid_pos > n_comps .and. cid_pos <= n_scripps ) then ! SCRIPPS moored buoyb zob = r0_45 kx = 193 - sstoe = 1.5_r_kind + sstoe = 0.75_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 + sstoe = half 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 + sstoe = 0.75_r_kind elseif ( cid_pos == 0 ) then ! All other moored buoysb (usually with 1-m observation depth) zob = one kx = 196 - sstoe = one + sstoe = 0.75_r_kind endif - elseif ( trim(subset) == 'NC001004' ) then ! LCMAN + elseif ( trim(subset) == 'NC001004' .or. trim(subset) == 'NC031003' .or. & ! LCMAN, TRKOB + trim(subset) == 'NC001005' .or. trim(subset) == 'NC001007' ) then ! TIDEG, CSTGD zob = one kx = 197 - sstoe = 2.5_r_kind + sstoe = one elseif ( trim(subset) == 'NC031002' ) then ! TESAC/ARGO if ( tpf(1,1) >= one .and. tpf(1,1) < 5.0_r_kind ) then zob = tpf(1,1) @@ -488,7 +489,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & zob = one endif kx = 198 - sstoe = 2.5_r_kind + sstoe = one elseif ( trim(subset) == 'NC031001' ) then ! BATHY if ( tpf(1,1) >= one .and. tpf(1,1) < 5.0_r_kind ) then zob = tpf(1,1) @@ -497,18 +498,6 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & endif kx = 199 sstoe = half - elseif ( trim(subset) == 'NC031003' ) then ! TRKOB - zob = one - kx = 200 - sstoe = two - elseif ( trim(subset) == 'NC001005' ) then ! TIDEG - zob = one - kx = 201 - sstoe = two - elseif ( trim(subset) == 'NC001007' ) then ! CSTGD - zob = one - kx = 202 - sstoe = two endif ! ! Determine usage diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index e62183e2e0..c8a520146e 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -133,6 +133,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) ! 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 +! 2019-09-20 X.Su -add read new variational qc table ! ! ! input argument list: @@ -378,10 +379,12 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) end if 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 + if(((said > 739) .and.(said < 746)).or.(said == 820).or. & + (said == 825).or. (said == 786).or.(said == 4) .or. & + (said == 3) .or. (said == 421).or.(said == 440).or. & + (said == 821).or. ((said > 749) .and.(said < 756)).or. & + (said == 44) .or. (said == 5) .or. & + ( GMAO_READ .and. said == 5) ) then lexist=.true. exit gpsloop end if @@ -430,7 +433,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) trim(subset) == 'NC005065' .or. trim(subset) == 'NC005066' .or.& trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or.& trim(subset) == 'NC005032' .or. trim(subset) == 'NC005034' .or.& - trim(subset) == 'NC005039') then + trim(subset) == 'NC005039' .or. trim(subset) == 'NC005091') then lexist = .true. exit loop endif @@ -694,7 +697,7 @@ subroutine read_obs(ndata,mype) reduce_diag,nobs_sub,dval_use use gsi_nstcouplermod, only: nst_gsi ! use gsi_nstcouplermod, only: gsi_nstcoupler_set - use qcmod, only: njqc,vadwnd_l2rw_qc + use qcmod, only: njqc,vadwnd_l2rw_qc,nvqc use gsi_4dvar, only: l4dvar use satthin, only: super_val,super_val1,superp,makegvals,getsfc,destroy_sfc use mpimod, only: ierror,mpi_comm_world,mpi_sum,mpi_rtype,mpi_integer,npe,& @@ -710,6 +713,7 @@ subroutine read_obs(ndata,mype) use convb_q,only:convb_q_read use convb_t,only:convb_t_read use convb_uv,only:convb_uv_read + use pvqc,only: readvqcdatfile 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,mbuoyb_info,read_ship_info @@ -811,6 +815,7 @@ subroutine read_obs(ndata,mype) else call converr_read(mype) endif + if(nvqc) call readvqcdatfile('vqctp001.dat',20,10,20,10,200,2) ! Optionally set random seed to perturb observations if (perturb_obs) then @@ -1733,7 +1738,7 @@ subroutine read_obs(ndata,mype) 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),dval_use) + nobs_sub1(1,i),read_rec(i),dval_use) string='READ_AHI' diff --git a/src/gsi/read_ozone.f90 b/src/gsi/read_ozone.f90 index 261a5aad6b..74c95e09db 100644 --- a/src/gsi/read_ozone.f90 +++ b/src/gsi/read_ozone.f90 @@ -129,6 +129,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & 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 + real(r_kind),parameter:: montoz = 100.0_r_kind !monitored ozone ! Declare local variables logical outside,version6,version8,iuse @@ -878,7 +879,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & do k=1,nloz if (iuse_oz(ipos(k)) < 0) then - usage1(k) = 100._r_kind + usage1(k) = montoz else usage1(k) = zero endif @@ -976,7 +977,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & 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 + usage1(k)=badoz ! 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 @@ -989,14 +990,14 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & 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 + if(hdrmlsl(1,k)>21700._r_kind .or. hdrmlsl(1,k)<1._r_kind) usage1(k)=badoz else if(mlsv==20) then - if(hdrmlsl(1,k)>6900._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=1000._r_kind + if(hdrmlsl(1,k)>6900._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=badoz else if(mlsv==30) then - if(hdrmlsl(1,k)>26500._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=1000._r_kind + if(hdrmlsl(1,k)>26500._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=badoz end if ! only positive precision accepted - if(hdrmlsl(3,k)<=0._r_kind) usage1(k)=1000._r_kind + if(hdrmlsl(3,k)<=0._r_kind) usage1(k)=badoz end do ! status screening @@ -1005,28 +1006,28 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & 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 + if(hdrmls13 <= 1.2_r_kind) usage1(k)=badoz else - if(hdrmls13 <= 0.4_r_kind) usage1(k)=1000._r_kind + if(hdrmls13 <= 0.4_r_kind) usage1(k)=badoz endif end do else if(hdrmls13 <= 0.4_r_kind) then do k=1,nloz - usage1(k)=1000._r_kind + usage1(k)=badoz 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 + usage1(k)=badoz 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 + usage1(k)=badoz end do end if end if @@ -1120,13 +1121,13 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & cycle read_loop5 endif - do k=1,nloz + do k=1,nloz if (iuse_oz(ipos(k)) < 0) then - usage1(k) = 1000._r_kind + usage1(k) = montoz else usage1(k) = zero endif - enddo + end do call ufbint(lunin,said,1,1,iret,"SAID") @@ -1187,7 +1188,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & omrstd(k) = lpsdvals(3,k) !omr std j = j + 1 if(omr(k) < 0._r_double .or. omr(k) > 100._r_double) then - usage1(k) = 1000._r_kind + usage1(k) = badoz j = j - 1 endif enddo diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 0ab30af8d8..8e8a08b970 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -139,11 +139,13 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! 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 +! 2019-09-27 Su - add hilbert curve application to aircraft winds ! 2018-08-16 akella - explicit KX definition for ships (formerly ID'd by subtype 522/523) ! 2019-02-06 levine - Add lookup of sensor height for mesonet winds ! 2019-06-17 mmorris - Update adjust_goescldobs to reject clear cloud obs over water at night +! 2019-09-27 Su - add hilbert curve application to aircraft winds ! 2019-12-05 mmorris - Update adjust_goescldobs to reject ALL clear cloud obs at night - +! ! input argument list: ! infile - unit from which to read BUFR data ! obstype - observation type to process @@ -168,6 +170,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use constants, only: zero,one_tenth,one,deg2rad,fv,t0c,half,& three,four,rad2deg,tiny_r_kind,huge_r_kind,huge_i_kind,& r60inv,r10,r100,r2000 + use constants,only: rearth,stndrd_atmos_ps,rd,grav use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,& tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,& rlats,rlons,twodvar_regional @@ -178,7 +181,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& 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 + use obsmod, only: blacklst,offtime_data,bmiss,ext_sonde,time_offset use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof,ntail,taillist,idx_tail,npredt,predt, & aircraft_t_bc_ext,ntail_update,max_tail,nsort,itail_sort,idx_sort,timelist use converr,only: etabl @@ -196,6 +199,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& 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 qcmod, only: pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres + use qcmod, only: nrand use nltransf, only: nltransf_forward use blacklist, only : blacklist_read,blacklist_destroy use blacklist, only : blkstns,blkkx,ibcnt @@ -215,6 +219,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use mpimod, only: npe use rapidrefresh_cldsurf_mod, only: i_gsdsfc_uselist,i_gsdqc,i_ens_mean use gsi_io, only: verbose + use phil2, only: denest ! hilbert curve implicit none @@ -365,6 +370,18 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& real(r_double),dimension(2,255,20):: tobaux real(r_double),dimension(2,255):: aircraftwk +! for hilbert curve + integer(i_kind) ndata_hil,nor,ncc,nnrand + integer(i_kind) indexx + real(r_kind) dentrip,dentrip_tmp,vmin,vmax,rmesh_tmp,pmesh_tmp,prest + integer(i_kind) ntime_max,ntime_tmp,itype,ikx + integer(i_kind),dimension(24) :: ntype_arr + integer(i_kind),allocatable,dimension(:,:) :: index_arr + real(r_kind),allocatable,dimension(:,:,:) :: data_hilb + real(r_kind),allocatable,dimension(:) :: rlat_hil,rlon_hil,height,wtob,wght_hilb +! end of block + + ! equivalence to handle character names equivalence(r_prvstg(1,1),c_prvstg) equivalence(r_sprvstg(1,1),c_sprvstg) @@ -455,7 +472,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(tob)then nreal=25 else if(uvob) then - nreal=25 + nreal=26 else if(spdob) then nreal=24 else if(psob) then @@ -568,7 +585,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (acft_profl_file .and. (.not. aircrafttype)) cycle ! skip non-aircrafttype for prepbufr_profl end if ithin=ithin_conv(nc) - if(ithin > 0)then + if(ithin > 0 .and. ithin <5)then ntread=ntread+1 ntx(ntread)=nc end if @@ -762,7 +779,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& call ufbint(lunin,levdat,1,255,levs,levstr) maxobs=maxobs+max(1,levs) nx=1 - if(ithin_conv(ncsave) > 0)then + if(ithin_conv(ncsave) > 0 .and. ithin_conv(ncsave) <5)then do ii=2,ntread if(ntx(ii) == ncsave)nx=ii end do @@ -837,7 +854,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(nx > 1) then nc=ntx(nx) ithin=ithin_conv(nc) - if (ithin > 0 ) then + if (ithin > 0 .and. ithin <5) then rmesh=rmesh_conv(nc) pmesh=pmesh_conv(nc) pmot=pmot_conv(nc) @@ -1643,7 +1660,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& stnelev=hdr(6) ithin=ithin_conv(nc) - ithinp = ithin > 0 .and. pflag /= 0 + ithinp = ithin > 0 .and. ithin <5 .and. pflag /= 0 if(.not. (driftl .or. (aircraft_t_bc .and. acft_profl_file)) .and. & (((tob .or. qob .or. uvob).and. levs > 1) .or. ithinp))then ! Interpolate guess pressure profile to observation location @@ -1950,8 +1967,8 @@ 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 + if (ithin > 0 .and. ithin <5 .and. usage <100.0_r_kind) then +! if (ithin > 0 .and. ithin <5) then ntmp=ndata ! counting moved to map3gridS ! Set data quality index for thinning @@ -2207,9 +2224,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name cdata_all(24,iout)=obsdat(10,k) ! cat cdata_all(25,iout)=var_jb(5,k) ! non linear qc parameter + cdata_all(26,iout)=one ! hilbert curve weight, modified later if(perturb_obs)then - cdata_all(26,iout)=ran01dom()*perturb_fact ! u perturbation - cdata_all(27,iout)=ran01dom()*perturb_fact ! v perturbation + cdata_all(27,iout)=ran01dom()*perturb_fact ! u perturbation + cdata_all(28,iout)=ran01dom()*perturb_fact ! v perturbation endif else if(spdob) then @@ -2934,6 +2952,165 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end do deallocate(iloc,isort,cdata_all) +! the following is gettin the types which will be applied hilbert curve to +! estimate the density + + if(obstype == 'uv') then + vmin=-10.00_r_kind + vmax=18000.00_r_kind + nor=0 + ithin=0 + allocate(wght_hilb(ndata)) + wght_hilb=one + pmesh=zero + rmesh=zero + dentrip=0 + pmesh_tmp=zero + rmesh_tmp=zero + dentrip_tmp=0 + ntime_max=0 + ntime_tmp=0 + ntime=0 + nnrand=nrand + do ncc=1,nconvtype + if( trim(ioctype(ncc)) == 'uv') then + itype=ictype(ncc) + if( itype ==230 .or. itype ==231 .or. itype ==233 ) then + if(itype ==230 .and. ithin_conv(ncc) >5) then + if(ptime_conv(ncc) >zero) then + ntime_max= int(6.0_r_kind/ptime_conv(ncc)) + else + ntime_max=1 + endif + pmesh=pmesh_conv(ncc) + rmesh=rmesh_conv(ncc) + dentrip=ithin_conv(ncc)/10 + else if(itype == 231 .and. ithin_conv(ncc) >5) then + if(ptime_conv(ncc) >zero) then + ntime_tmp=int(6.0_r_kind/ptime_conv(ncc)) + else + ntime_tmp=1 + endif + pmesh_tmp=pmesh_conv(ncc) + rmesh_tmp=rmesh_conv(ncc) + dentrip_tmp=ithin_conv(ncc)/10 + if(pmesh >zero .and. rmesh >zero) then + if(ntime_tmp /= ntime_max .or. pmesh_tmp /= pmesh .or. & + rmesh_tmp /= rmesh .or. dentrip_tmp /= dentrip) then + write(6,*) 'READ_PREPBUFR:WARING convinfo file settings are not right,use first one itype=',itype + write(6,*) 'READ_PREPBUFR: ntime_max,pmesh,rmesh,ntime_tmp,pmesh_tmp,rmesh_tmp,rmesh_tmp=',& + ntime_max,pmesh,rmesh,ntime_tmp,pmesh_tmp,rmesh_tmp,dentrip_tmp + endif + else if(pmesh_tmp >zero .and. rmesh_tmp >zero) then + pmesh=pmesh_tmp + rmesh=rmesh_tmp + ntime_max=ntime_tmp + endif + else if(itype == 233 .and. ithin_conv(ncc) >5) then + if(ptime_conv(ncc) >zero) then + ntime_tmp=int(6.0_r_kind/ptime_conv(ncc)) + else + ntime_tmp=1 + endif + pmesh_tmp=pmesh_conv(ncc) + rmesh_tmp=rmesh_conv(ncc) + dentrip_tmp=ithin_conv(ncc)/10 + if(pmesh >zero .and. rmesh >zero) then + if(ntime_tmp /= ntime_max .or. pmesh_tmp /= pmesh .or. & + rmesh_tmp /= rmesh .or. dentrip_tmp /= dentrip) then + write(6,*) 'READ_PREPBUFR:WARING convinfo file settings are not right,use first one itype=',itype + write(6,*) 'READ_PREPBUFR: ntime_max,pmesh,rmesh,ntime_tmp,pmesh_tmp,rmesh_tmp,rmesh_tmp=',& + ntime_max,pmesh,rmesh,ntime_tmp,pmesh_tmp,rmesh_tmp,dentrip_tmp + endif + else if(pmesh_tmp >zero .and. rmesh_tmp >zero) then + pmesh=pmesh_tmp + rmesh=rmesh_tmp + ntime_max=ntime_tmp + endif + endif + endif + endif + enddo + + write(6,*),'READ_PREPBUFR:dentrip,pmesh,rmesh,ndata=',dentrip,pmesh,rmesh,ntime_max,ndata + if(dentrip >= one .and. pmesh >zero .and. rmesh >zero) then + allocate(data_hilb(3,ndata,6),index_arr(ndata,ntime_max)) + + ndata_hil=0 + ntype_arr=0 + ntime=1 + index_arr=0 + + do k=1,ndata + ikx=nint(cdata_out(10,k)) + itype=ictype(ikx) + if( itype ==230 .or. itype ==231 .or. itype ==233) then + prest=r10*exp(cdata_out(4,k)) + if (prest <100.0_r_kind) cycle + if(ithin_conv(ikx) >=5) then + if(ptime_conv(ikx) >zero) then + ntime=int(((cdata_out(9,k)-time_offset)+three)/ptime_conv(ikx))+1 + endif + if(ntime >ntime_max) ntime=ntime_max + if(ntime <0) ntime=1 + ntype_arr(ntime)=ntype_arr(ntime)+1 + ndata_hil=ntype_arr(ntime) + data_hilb(1,ndata_hil,ntime)=cdata_out(20,k) + data_hilb(2,ndata_hil,ntime)=cdata_out(19,k) + prest=prest*100.0_r_kind + if(prest >stndrd_atmos_ps) then + prest=zero + else + prest=rd*265.00_r_kind*log(stndrd_atmos_ps/prest)/grav + endif + data_hilb(3,ndata_hil,ntime)=prest + index_arr(ndata_hil,ntime)=k + if(data_hilb(1,ndata_hil,ntime) >90.0_r_kind .or. & + data_hilb(1,ndata_hil,ntime) <-90.0_r_kind .or. & + data_hilb(2,ndata_hil,ntime) 360.0_r_kind .or. & + data_hilb(3,ndata_hil,ntime) vmax ) then + write(6,*),'READ_PREPBUFR :something is wrong,lat,lon,prest=',& + data_hilb(1,ndata_hil,ntime),& + data_hilb(2,ndata_hil,ntime),& + cdata_out(4,k),data_hilb(3,ndata_hil,ntime) + endif + endif + endif + enddo + rmesh=rmesh*1000.0_r_kind + do kk=1,ntime_max + ndata_hil=ntype_arr(kk) + if(ndata_hil >=2) then + allocate(rlat_hil(ndata_hil),rlon_hil(ndata_hil),height(ndata_hil),wtob(ndata_hil)) + rlat_hil(1:ndata_hil)=data_hilb(1,1:ndata_hil,kk) + rlon_hil(1:ndata_hil)=data_hilb(2,1:ndata_hil,kk) + height(1:ndata_hil)=data_hilb(3,1:ndata_hil,kk) + call denest(ndata_hil,nnrand,nor,rearth,dentrip,rmesh,pmesh,& + vmin,vmax,rlat_hil,rlon_hil,height,wtob) + do i=1,ndata_hil + indexx=index_arr(i,kk) + wght_hilb(indexx)=wtob(i) + enddo + ndata_hil=0 + deallocate(rlat_hil,rlon_hil,height,wtob) + endif + enddo + deallocate(data_hilb,index_arr) + endif + + do i=1,ndata + cdata_out(26,i)=wght_hilb(i) + enddo + + deallocate(wght_hilb) + endif +! end of hilbert curve + + + + ! define a closest METAR cloud observation for each grid point if(metarcldobs .and. ndata > 0) then @@ -2956,6 +3133,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata write(lunout) cdata_out + + deallocate(cdata_out) call destroy_rjlists call destroy_aircraft_rjlists diff --git a/src/gsi/read_saphir.f90 b/src/gsi/read_saphir.f90 index 7330a86ada..e4d7c55bde 100644 --- a/src/gsi/read_saphir.f90 +++ b/src/gsi/read_saphir.f90 @@ -344,7 +344,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& if(abs(tdiff) > twind+one_minute) cycle read_loop endif - crit0 = 0.00_r_kind ! forced to >= 0.01_r_kind in tdiff2crit() + crit0 = 0.01_r_kind timeinflat=two call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index 7eb0a7bb9d..c3fcf290cf 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -69,7 +69,9 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! - 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 -! +! 2019-9-25 Su - modified ithin value criteria to distinguash thinning +! or hilber curve downweighting +! ! ! ! input argument list: @@ -262,7 +264,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Set lower limits for observation errors werrmin=one nsattype=0 - nreal=25 + nreal=26 if(perturb_obs ) nreal=nreal+2 ntread=1 ntmatch=0 @@ -274,7 +276,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ntmatch=ntmatch+1 ntxall(ntmatch)=nc ithin=ithin_conv(nc) - if(ithin > 0)then + if(ithin > 0 .and. ithin <5)then ntread=ntread+1 ntx(ntread)=nc end if @@ -406,6 +408,20 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis itype=260 endif endif + else if(trim(subset) == 'NC005091') then ! VIIRS N-20 with new sequence +! Commented out, because we need clarification for SWCM/hdrdat(9) from Yi Song +! NOTE: Once it is confirmed that SWCM values are sensible, apply this logic and +! replace lines 685-702 + ! if(hdrdat(9) == one) then ! VIIRS IR + ! winds + ! itype=260 + ! endif +!Temporary solution replacing the commented code above + if(trim(subset) == 'NC005091') then ! IR LW winds + itype=260 + endif + + !GOES-R section of the 'if' statement over 'subsets' else if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. & trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039') then @@ -469,7 +485,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis if(ncsave /= 0) then maxobs=maxobs+1 nx=1 - if(ithin_conv(ncsave) > 0)then + if(ithin_conv(ncsave) > 0 .and. ithin_conv(ncsave) <5)then do ii=2,ntread if(ntx(ii) == ncsave)nx=ii end do @@ -504,7 +520,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis if(nx >1) then nc=ntx(nx) ithin=ithin_conv(nc) - if (ithin > 0 ) then + if (ithin > 0 .and. ithin <5) then rmesh=rmesh_conv(nc) pmesh=pmesh_conv(nc) pmot=pmot_conv(nc) @@ -875,6 +891,55 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis endif enddo endif +! Extra block for VIIRS NOAA-20: Start + else if(trim(subset) == 'NC005091') then + if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! The range of satellite IDs + c_prvstg='VIIRS' + if(trim(subset) == 'NC005091') then ! IR LW winds + itype=260 + c_station_id='IR'//stationid + c_sprvstg='IR' + !write(6,*)'itype= ',itype + endif + +! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}') +! irep_array = int(rep_array) +! allocate( amvaha(4,irep_array)) +! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST +! HOCT') +! deallocate( amvaha ) +! +! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}') +! irep_array = int(rep_array) +! allocate( amviii(12,irep_array)) +! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID +! SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST') +! deallocate( amviii ) + + call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') + irep_array = int(rep_array) + allocate( amvivr(2,irep_array)) + call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') + pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova + deallocate( amvivr ) + +! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}') +! irep_array = int(rep_array) +! allocate( amvcld(12,irep_array)) +! ! MUCE --> MUNCEX within the new GOES16/17 and NOAA-20 VIIRS +! sequence (I.Genkova, J.Whiting) +! ! THIS CHANGE HAS NOT BEEN TESTED !!! +! !call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE +! VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT') +! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUNCEX +! VSAT TMDBST VSAT CDTP MUNCEX OECS CDTP HOCT COPT') +! deallocate( amvcld ) + + call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF + qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR + ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] + endif +! Extra block for VIIRS NOAA20: End ! 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 @@ -1194,7 +1259,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis !! process the thining procedure ithin=ithin_conv(nc) - ithinp = ithin > 0 .and. pflag /= 0 + ithinp = ithin > 0 .and. ithin <5 .and. pflag /= 0 ! if(ithinp .and. iuse >=0 )then if(ithinp )then ! Interpolate guess pressure profile to observation location @@ -1218,7 +1283,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis dlnpob=log(one_tenth*ppb) ! ln(pressure in cb) ppb=one_tenth*ppb ! from mb to cb ! Special block for data thinning - if requested - if (ithin > 0 .and. iuse >=0 .and. qm <4) then + if (ithin > 0 .and. ithin <5 .and. iuse >=0 .and. qm <4) then ntmp=ndata ! counting moved to map3gridS ! Set data quality index for thinning if (thin4d) then @@ -1321,7 +1386,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cdata_all(8,iout)=rstation_id ! station id cdata_all(9,iout)=t4dv ! time cdata_all(10,iout)=nc ! index of type in convinfo file - cdata_all(11,iout)=qifn +1000.0_r_kind*qify ! quality indictator + cdata_all(11,iout)=qifn +1000.0_r_kind*qify ! quality indicator cdata_all(12,iout)=qm ! quality mark cdata_all(13,iout)=obserr ! original obs error cdata_all(14,iout)=usage ! usage parameter @@ -1335,10 +1400,11 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cdata_all(22,iout)=r_prvstg(1,1) ! provider name cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name cdata_all(25,iout)=var_jb ! non linear qc parameter + cdata_all(26,iout)=one ! hilbert curve weight if(perturb_obs)then - cdata_all(26,iout)=ran01dom()*perturb_fact ! u perturbation - cdata_all(27,iout)=ran01dom()*perturb_fact ! v perturbation + cdata_all(27,iout)=ran01dom()*perturb_fact ! u perturbation + cdata_all(28,iout)=ran01dom()*perturb_fact ! v perturbation endif enddo loop_readsb diff --git a/src/gsi/read_seviri.f90 b/src/gsi/read_seviri.f90 index 030002c433..9b01d3df04 100644 --- a/src/gsi/read_seviri.f90 +++ b/src/gsi/read_seviri.f90 @@ -118,9 +118,9 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& 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 ! seviri imager header - real(r_kind),allocatable,dimension(:,:):: datasev1,datasev2 ! seviri imager data - real(r_kind) rclrsky + real(r_kind),allocatable,dimension(:):: hdr ! seviri imager header + real(r_kind),allocatable,dimension(:,:):: datasev,datasev1,datasev2,datasev3 ! seviri imager data + real(r_kind) rclrsky,rcldfrc real(r_kind) :: zob,tref,dtw,dtc,tz_tr real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00 @@ -136,7 +136,7 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& integer(i_kind) :: sdsize,jrec,nnmsg,nnsb !************************************************************************** ! Initialize variables - maxinfo=31 + maxinfo=32 lnbufr = 10 disterrmax=zero ntest=0 @@ -232,12 +232,15 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& ncld=2 nbrst=nchn*6 ! channel dependent: all, clear, cloudy, low, middle and high clouds endif + allocate(datasev(1,4)) ! CLDMNT for ASR: not channel dependent allocate(datasev1(1,ncld)) ! not channel dependent allocate(datasev2(1,nbrst)) ! channel dependent: all, clear, cloudy, low, middle and high clouds + allocate(datasev3(1,nbrst)) ! SDTB: channel dependent 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 @@ -355,17 +358,27 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& nread=nread+nchanl - call ufbrep(lnbufr,datasev1,1,ncld,iret,'NCLDMNT') - rclrsky=bmiss - do n=1,ncld - if(datasev1(1,n)>= zero .and. datasev1(1,n) <= 100.0_r_kind ) then - rclrsky=datasev1(1,n) + rcldfrc=zero + if(clrsky) then + call ufbrep(lnbufr,datasev1,1,ncld,iret,'NCLDMNT') + rclrsky=bmiss +! datasev1(1,5) is high-peaking water vapor channel +! for SEVIRI CSR, clear-sky percentage are different between the high-peaking WV channel and other channels + if(datasev1(1,5)>= zero .and. datasev1(1,5) <= 100.0_r_kind ) then + rclrsky=datasev1(1,5) ! first QC filter out data with less clear sky fraction if ( rclrsky < r70 ) cycle read_loop end if - end do + else if(allsky) then + call ufbrep(lnbufr,datasev1,1,2,iret,'NCLDMNT') + rclrsky=datasev1(1,1) !clear-sky percentage +! rclrsky=datasev1(1,2) !clear-sky percentage over sea + call ufbrep(lnbufr,datasev,1,4,iret,'CLDMNT') + rcldfrc=datasev(1,1) !total cloud + end if call ufbrep(lnbufr,datasev2,1,nbrst,iret,'TMBRST') + call ufbrep(lnbufr,datasev3,1,nbrst,iret,'SDTB') allchnmiss=.true. do n=4,11 @@ -375,6 +388,15 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& end do if(allchnmiss) cycle read_loop +! toss data if SDTB>1.3 + do i=4,11 + if(i==5 .or. i==6) then ! 2 water-vapor channels + if(datasev3(1,i)>1.3_r_kind) then + cycle read_loop + end if + end if + end do + ! Locate the observation on the analysis grid. Get sst and land/sea/ice ! mask. @@ -390,16 +412,21 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& 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 + call checkob(dist1,crit1,itx,iuse) + if(.not. iuse)cycle read_loop ! Set common predictor parameters -!test - pred=zero -!test + if(clrsky) then +! use NCLDMNT from chn9 (10.8 micron) as a QC predictor +! add SDTB from chn9 as QC predictor + pred=10-datasev1(1,9)/10.0_r_kind+datasev3(1,9)*10.0_r_kind + else + pred=zero + end if ! Compute "score" for observation. All scores>=0.0. Lowest score is "best" + pred=zero !ignore the rclrsky and SDTB for thinning for now crit1 = crit1+pred call finalcheck(dist1,crit1,itx,iuse) @@ -452,10 +479,19 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& 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 SEVASR + do k=1,nchanl + if(clrsky) then + data_all(32+k,itx) = datasev3(1,k+3) ! BT standard deviation from SEVCSR + else if(allsky) then + jj=(k+2)*6+1 + data_all(32+k,itx) = datasev3(1,jj) ! BT standard deviation from SEVASR + end if + end do if(dval_use)then - data_all(32,itx) = val_sev - data_all(33,itx) = itt + data_all(maxinfo-1,itx) = val_sev + data_all(maxinfo,itx) = itt end if if ( nst_gsi > 0 ) then @@ -496,7 +532,7 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& end do if(dval_use .and. assim)then do n=1,ndata - itt=nint(data_all(33,n)) + itt=nint(data_all(maxinfo,n)) super_val(itt)=super_val(itt)+val_sev end do end if @@ -510,7 +546,7 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& ! Deallocate local arrays deallocate(data_all,nrec) - deallocate(hdr,datasev2,datasev1) + deallocate(hdr,datasev2,datasev1,datasev3,datasev) if(allocated(subset_num)) deallocate(subset_num) if(allocated(subset_nnsb)) deallocate(subset_nnsb) diff --git a/src/gsi/read_ssmis.f90 b/src/gsi/read_ssmis.f90 index fc5095deca..faaec0cece 100755 --- a/src/gsi/read_ssmis.f90 +++ b/src/gsi/read_ssmis.f90 @@ -469,7 +469,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& if(abs(tdiff) > twind+one_minute) cycle read_loop endif - crit0 = 0.00_r_kind ! forced to >= 0.01_r_kind in tdiff2crit() + crit0 = 0.01_r_kind timeinflat=6.0_r_kind call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) diff --git a/src/gsi/rtma_comp_fact10.f90 b/src/gsi/rtma_comp_fact10.f90 index 6118df2dc1..ccd8b98bdb 100644 --- a/src/gsi/rtma_comp_fact10.f90 +++ b/src/gsi/rtma_comp_fact10.f90 @@ -68,7 +68,7 @@ subroutine init_aux2dvarflds(mype) ! machine: ibm RS/6000 SP ! !$$$ end documentation block - use guess_grids, only: nfldsig,hrdifsig + use guess_grids, only: nfldsig use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_metguess_mod, only : gsi_metguess_bundle use mpeu_util, only: die diff --git a/src/gsi/satthin.F90 b/src/gsi/satthin.F90 index ffd8f561aa..e2c5da8be4 100644 --- a/src/gsi/satthin.F90 +++ b/src/gsi/satthin.F90 @@ -46,6 +46,7 @@ module satthin ! 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. +! 2019-09-24 martin - added in option for use_gfs_ncio for getsfc ! ! Subroutines Included: ! sub makegvals - set up for superob weighting @@ -494,6 +495,7 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) ! (1) move gsi_nstcoupler_init and gsi_nstcoupler_read from read_obs.F90 to getsfc here ! (2) use sfcnst_comb from name list ! (3) modify subroutine getsfc to read a sfc & nst combined file +! 2019-09-24 martin - added in option for use_gfs_ncio ! ! input argument list: ! mype - current processor @@ -512,7 +514,7 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) use gridmod, only: nlat,nlon,lat2,lon2,lat1,lon1,jstart,& iglobal,itotsub,ijn,displs_g,regional,istart, & rlats,rlons,nlat_sfc,nlon_sfc,rlats_sfc,rlons_sfc,strip,& - sfcnst_comb,use_gfs_nemsio,use_readin_anl_sfcmask + sfcnst_comb,use_gfs_nemsio,use_readin_anl_sfcmask,use_gfs_ncio use general_commvars_mod, only: ltosi,ltosj use guess_grids, only: ntguessig,isli,sfct,sno,fact10, & nfldsfc,ntguessfc,soil_moi,soil_temp,veg_type,soil_type, & @@ -524,6 +526,7 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) use constants, only: zero,half,pi,two,one use ncepgfs_io, only: read_gfssfc,read_gfssfc_anl use ncepnems_io, only: read_nemssfc,intrp22,read_nemssfc_anl + use netcdfgfs_io, only: read_gfsncsfc, read_gfsncsfc_anl use sfcio_module, only: sfcio_realfill use obsmod, only: lobserver use gsi_nstcouplermod, only: nst_gsi,gsi_nstcoupler_read @@ -621,6 +624,25 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) call read_nemssfc_anl(mype_io,isli_anl) endif + else if ( use_gfs_ncio ) then + + if ( sfcnst_comb .and. nst_gsi > 0 ) then + call read_gfsncsfc(mype_io, & + sst_full,soil_moi_full,sno_full,soil_temp_full, & + veg_frac_full,fact10_full,sfc_rough_full, & + veg_type_full,soil_type_full,zs_full_gfs,isli_full,use_sfc_any,& + 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) + else + call read_gfsncsfc(mype_io, & + sst_full,soil_moi_full,sno_full,soil_temp_full, & + veg_frac_full,fact10_full,sfc_rough_full, & + veg_type_full,soil_type_full,zs_full_gfs,isli_full,use_sfc_any) + endif ! if ( nst_gsi > 0 ) then + + if ( use_readin_anl_sfcmask ) then + call read_gfsncsfc_anl(mype_io,isli_anl) + endif + else call read_gfssfc(mype_io, & sst_full,soil_moi_full,sno_full,soil_temp_full, & diff --git a/src/gsi/setupbend.f90 b/src/gsi/setupbend.f90 index a1a36eec05..9a83034428 100644 --- a/src/gsi/setupbend.f90 +++ b/src/gsi/setupbend.f90 @@ -115,7 +115,7 @@ subroutine setupbend(obsLL,odiagLL, & use mpeu_util, only: die,perr,tell,getindex use kinds, only: r_kind,i_kind use m_gpsStats, only: gps_allhead,gps_alltail - use obsmod , only: nprof_gps,grids_dim,lobsdiag_allocated,& + use obsmod , only: nprof_gps,lobsdiag_allocated,& lobsdiagsave,nobskeep,& time_offset,lobsdiag_forenkf use m_obsNode, only: obsNode @@ -138,9 +138,10 @@ subroutine setupbend(obsLL,odiagLL, & use guess_grids, only: nsig_ext,gpstop use gridmod, only: nsig use gridmod, only: get_ij,latlon11 - use constants, only: fv,n_a,n_b,n_c,deg2rad,tiny_r_kind,r0_01 + use constants, only: fv,n_a,n_b,n_c,deg2rad,tiny_r_kind,r0_01,r18,r61,r63,r10000 use constants, only: zero,half,one,two,eccentricity,semi_major_axis,& - grav_equator,somigliana,flattening,grav_ratio,grav,rd,eps,three,four,five + grav_equator,somigliana,flattening,grav_ratio,grav,rd,eps,three,four,five,& + r100,r400 use lagmod, only: setq, setq_TL use lagmod, only: slagdw, slagdw_TL use jfunc, only: jiter,miter,jiterstart @@ -187,26 +188,25 @@ subroutine setupbend(obsLL,odiagLL, & real(r_kind),parameter:: eight = 8.0_r_kind real(r_kind),parameter:: nine = 9.0_r_kind real(r_kind),parameter:: eleven = 11.0_r_kind - real(r_kind),parameter:: ds=10000.0_r_kind real(r_kind),parameter:: r12=12.0_r_kind - real(r_kind),parameter:: r18=18.0_r_kind real(r_kind),parameter:: r20=20.0_r_kind real(r_kind),parameter:: r40=40.0_r_kind real(r_kind),parameter:: r1em3 = 1.0e-3_r_kind real(r_kind),parameter:: r1em6 = 1.0e-6_r_kind character(len=*),parameter :: myname='setupbend' real(r_kind),parameter:: crit_grad = 157.0_r_kind + real(r_kind),parameter:: r790000=790000.0_r_kind ! Declare local variables - + integer(i_kind):: grids_dim real(r_kind) cutoff,cutoff1,cutoff2,cutoff3,cutoff4,cutoff12,cutoff23,cutoff34 - real(r_kind) sin2,zsges - real(r_kind),dimension(grids_dim):: ddnj,grid_s,ref_rad_s + real(r_kind) sin2,zsges,ds,ns + real(r_kind),dimension(:),allocatable:: ddnj,grid_s,ref_rad_s real(r_kind) rsig,rsig_up,ddbend,tmean,qmean real(r_kind) termg,termr,termrg,hob,dbend,grad_mod real(r_kind) fact,pw,nrefges1,nrefges2,nrefges3,k4,delz - real(r_kind) ratio,residual,obserror,obserrlm + real(r_kind) ratio,residual,obserror,obserrlm,cermaxuse,cerminuse,cgrossuse real(r_kind) errinv_input,errinv_adjst,errinv_final,err_final,repe_gps real(r_kind),dimension(nele,nobs):: data @@ -280,6 +280,7 @@ subroutine setupbend(obsLL,odiagLL, & !750-755 => COSMIC-2 Equatorial !724-729 => COSMIC-2 Polar !825 => KOMPSAT-5 +!5 => MetOpC ! Check to see if required guess fields are available call check_vars_(proceed) @@ -316,8 +317,12 @@ subroutine setupbend(obsLL,odiagLL, & nobs_out=0 hob_s_top=one mm1=mype+1 - nsigstart=min(23,nsig) - + ns=nsig/two + nsigstart=nint(ns) + ns=(r61/r63)*nsig+r18 + grids_dim=nint(ns) ! grid points for integration of GPS bend + ds=r10000 + allocate(ddnj(grids_dim),grid_s(grids_dim),ref_rad_s(grids_dim)) ! Allocate arrays for output to diagnostic file mreal=22 @@ -328,6 +333,29 @@ subroutine setupbend(obsLL,odiagLL, & nind = 3 ! number of dense subarrays call new(dhx_dx, nnz, nind) nreal = nreal + size(dhx_dx) + ! jacobian sparse array indices are the same for all obs and can be filled + ! in once here: + 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 endif if(init_pass) call gpsrhs_alloc(is,'bend',nobs,nsig,nreal,grids_dim,nsig_ext) call gpsrhs_aliases(is) @@ -580,10 +608,12 @@ subroutine setupbend(obsLL,odiagLL, & repe_gps=one ! UKMET-type processing - if((data(isatid,i)==41).or.(data(isatid,i)==722).or.& - (data(isatid,i)==723).or.(data(isatid,i)==4).or.(data(isatid,i)==42).or.& - (data(isatid,i)==3).or.(data(isatid,i)==821.or.(data(isatid,i)==421)).or.& - (data(isatid,i)==440).or.(data(isatid,i)==43)) then + if((data(isatid,i)==41) .or.(data(isatid,i)==722).or. & + (data(isatid,i)==723).or.(data(isatid,i)==4) .or. & + (data(isatid,i)==42) .or.(data(isatid,i)==3) .or. & + (data(isatid,i)==821).or.(data(isatid,i)==421).or. & + (data(isatid,i)==440).or.(data(isatid,i)==43) .or. & + (data(isatid,i)==5)) then if((data(ilate,i)> r40).or.(data(ilate,i)< -r40)) then if(alt>r12) then @@ -708,14 +738,21 @@ subroutine setupbend(obsLL,odiagLL, & data(igps,i)=data(igps,i)-dbend !innovation vector if (alt <= gpstop) then ! go into qc checks - + cgrossuse=cgross(ikx) + cermaxuse=cermax(ikx) + cerminuse=cermin(ikx) + if (alt > five) then + cgrossuse=cgrossuse*r400 + cermaxuse=cermaxuse*r400 + cerminuse=cerminuse*r100 + endif ! Gross error check obserror = one/max(ratio_errors(i)*data(ier,i),tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + obserrlm = max(cerminuse,min(cermaxuse,obserror)) residual = abs(data(igps,i)) ratio = residual/obserrlm - if (ratio > cgross(ikx)) then + if (ratio > cgrossuse) then if (luse(i)) then awork(4) = awork(4)+one endif @@ -769,7 +806,8 @@ subroutine setupbend(obsLL,odiagLL, & endif ! Remove MetOP/GRAS data below 8 km - if((alt <= eight) .and. ((data(isatid,i)==4) .or. (data(isatid,i)==3))) then + if( (alt <= eight) .and. & + ((data(isatid,i)==4).or.(data(isatid,i)==3).or.(data(isatid,i)==5))) then qcfail(i)=.true. data(ier,i) = zero ratio_errors(i) = zero @@ -955,10 +993,13 @@ subroutine setupbend(obsLL,odiagLL, & enddo end associate ! odiag endif - - do j=1,nreal - gps_alltail(ibin)%head%rdiag(j)= rdiagbuf(j,i) - end do + + ! if obs is not "acceptable" and jacobian is not computed, fill jacobian + ! with zeros + if (save_jacobian) then + dhx_dx%val = 0._r_kind + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,i)) + endif ! If obs is "acceptable", load array with obs info for use ! in inner loop minimization (int* and stp* routines) @@ -1096,29 +1137,7 @@ subroutine setupbend(obsLL,odiagLL, & 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 - + ! fill in the jacobian do iz = 1, nsig dhx_dx%val(iz) = my_head%jac_t(iz) dhx_dx%val(iz+nsig) = my_head%jac_q(iz) @@ -1129,10 +1148,6 @@ subroutine setupbend(obsLL,odiagLL, & 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) @@ -1149,9 +1164,12 @@ subroutine setupbend(obsLL,odiagLL, & my_head => null() end if ! (in_curbin .and. muse=1) + do j=1,nreal + gps_alltail(ibin)%head%rdiag(j)= rdiagbuf(j,i) + end do endif ! (last_pass) end do ! i=1,nobs - + deallocate(ddnj,grid_s,ref_rad_s) ! Release memory of local guess arrays call final_vars_ diff --git a/src/gsi/setupdw.f90 b/src/gsi/setupdw.f90 index 9c5fa29638..93749b2ad9 100644 --- a/src/gsi/setupdw.f90 +++ b/src/gsi/setupdw.f90 @@ -53,7 +53,7 @@ subroutine setupdw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa use m_obsLList, only: obsLList use obsmod, only: luse_obsdiag use gsi_4dvar, only: nobs_bins,hr_obsbin - use state_vectors, only: svars3d, levels, nsdim + use state_vectors, only: svars3d, levels use jfunc, only: last, jiter, miter, jiterstart use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype @@ -199,7 +199,6 @@ subroutine setupdw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa real(r_kind) :: delz type(sparr2) :: dhx_dx - real(r_single), dimension(nsdim) :: dhx_dx_array integer(i_kind) :: iz, u_ind, v_ind, nind, nnz character(8) station_id @@ -818,7 +817,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ subroutine contents_binary_diag_(odiag) @@ -951,8 +953,9 @@ subroutine contents_netcdf_diag_(odiag) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", 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 end subroutine contents_netcdf_diag_ diff --git a/src/gsi/setuplwcp.f90 b/src/gsi/setuplwcp.f90 index 97acf36fc5..a1f9e73d71 100644 --- a/src/gsi/setuplwcp.f90 +++ b/src/gsi/setuplwcp.f90 @@ -70,7 +70,7 @@ subroutine setuplwcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag 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 state_vectors, only: svars3d, levels use constants, only: zero,one,tpwcon,r1000,r10, & tiny_r_kind,three,half,two,cg_term,huge_single,& @@ -133,7 +133,6 @@ subroutine setuplwcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag 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 @@ -764,7 +763,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ @@ -885,8 +887,9 @@ subroutine contents_netcdf_diag_(odiag) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", 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 end subroutine contents_netcdf_diag_ diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index bfc4480d0d..685514ca70 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -110,7 +110,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use mpeu_util, only: die,perr,getindex use kinds, only: r_kind,r_single,i_kind - use state_vectors, only: svars3d, levels, nsdim + use state_vectors, only: svars3d, levels use constants, only : zero,half,one,two,tiny_r_kind use constants, only : rozcon,cg_term,wgtlim,h300,r10 @@ -191,10 +191,10 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ! Declare local variables - real(r_kind) omg,rat_err2,dlat,dtime,dlon + real(r_kind) omg,rat_err2,dlat,dtime,dlon,rat_err4diag 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):: ozges,varinv3,ozone_inv,ozobs,varinv4diag real(r_kind),dimension(nlevs):: ratio_errors,error real(r_kind),dimension(nlevs-1):: ozp real(r_kind),dimension(nloz_omi) :: ozp_omi @@ -212,7 +212,6 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& 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 @@ -514,6 +513,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& end if endif + varinv4diag(k)=varinv3(k) + rat_err4diag=rat_err2 + ! If not assimilating this observation, reset inverse variance to zero if (iouse(k)<1) then varinv3(k)=zero @@ -527,7 +529,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& if (ozone_diagsave .and. luse(i)) then rdiagbuf(1,k,ii) = ozobs(k) rdiagbuf(2,k,ii) = ozone_inv(k) ! obs-ges - errorinv = sqrt(varinv3(k)*rat_err2) + errorinv = sqrt(varinv4diag(k)*rat_err4diag) rdiagbuf(3,k,ii) = errorinv ! inverse observation error if (obstype == 'gome' .or. obstype == 'omieff' .or. & obstype == 'omi' .or. obstype == 'tomseff' .or. & @@ -587,8 +589,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& call nc_diag_metadata("Row_Anomaly_Index", sngl(rmiss) ) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", 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 endif endif @@ -917,13 +920,16 @@ subroutine init_netcdf_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 ) call nc_diag_header("Satellite_Sensor", isis) call nc_diag_header("Satellite", dplat(is)) call nc_diag_header("Observation_type", obstype) call nc_diag_header("pobs", pobs) call nc_diag_header("gross",gross) call nc_diag_header("tnoise",tnoise) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ @@ -1091,12 +1097,12 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& real(r_kind) o3ges, o3ppmv real(r_kind) rlow,rhgh,sfcchk - real(r_kind) omg,rat_err2,dlat,dtime,dlon + real(r_kind) omg,rat_err2,dlat,dtime,dlon,rat_err4diag 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) varinv3,ratio_errors,varinv4diag real(r_kind) dpres,obserror,ozone_inv,preso3l real(r_kind),dimension(nreal+nlevs,nobs):: data real(r_kind),dimension(nsig):: prsltmp @@ -1329,7 +1335,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& endif ! toss the obs not recommended by the data provider - if (nint(data(iuse,i)) == 1000 ) then + if (nint(data(iuse,i)) == 10000 ) then varinv3=zero ratio_errors=zero endif @@ -1382,6 +1388,9 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& end if endif + varinv4diag=varinv3 + rat_err4diag=rat_err2 + ! If not assimilating this observation, reset inverse variance to zero if ( .not. muse(i)) then varinv3=zero @@ -1432,7 +1441,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ! Optionally save data for diagnostics if (ozone_diagsave .and. luse(i)) then - errorinv = sqrt(varinv3*rat_err2) + errorinv = sqrt(varinv4diag*rat_err4diag) if (binary_diag) call contents_binary_diag_(my_diag) if (netcdf_diag) call contents_netcdf_diag_(my_diag) diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90 index 93532e27de..3851b8d10e 100644 --- a/src/gsi/setupps.f90 +++ b/src/gsi/setupps.f90 @@ -80,7 +80,7 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa ! . Remove my_node with corrected typecast(). ! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis ! time in analysis -! +! 2019-09-20 Su - remove current VQC part and add subroutine call on VQC and add new VQC option ! ! input argument list: ! lunin - unit from which to read observations @@ -98,7 +98,7 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa ! !$$$ use mpeu_util, only: die,perr,getindex - use state_vectors, only: svars2d, levels, ns3d, nsdim + use state_vectors, only: svars2d, levels, ns3d use kinds, only: r_kind,r_single,r_double,i_kind use m_obsdiagNode, only: obs_diag use m_obsdiagNode, only: obs_diags @@ -123,12 +123,13 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa 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, & + huge_r_kind,tiny_r_kind,two,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 qcmod, only: dfact,dfact1,npres_print,vqc,nvqc use guess_grids, only: hrdifsig,ges_lnprsl,nfldsig,ntguessig use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,icsubtype + use convinfo, only: ibeta,ikapa use m_dtime, only: dtime_setup, dtime_check @@ -170,7 +171,7 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa 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) cg_t,cvar,wgt,rat_err2,qcgross real(r_kind),dimension(nobs):: dup real(r_kind),dimension(nsig):: prsltmp real(r_kind),dimension(nele,nobs):: data @@ -181,6 +182,7 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa integer(i_kind) ikxx,nn,ibin,ioff,ioff0 integer(i_kind) i,nchar,nreal,ii,jj,k,l,mm1 integer(i_kind) itype,isubtype + integer(i_kind) ibb,ikk logical,dimension(nobs):: luse,muse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID @@ -207,7 +209,6 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa 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 @@ -508,38 +509,29 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa ! Compute penalty terms, and accumulate statistics. val = error*ddiff - + if(nvqc .and. ibeta(ikx) >0 ) ratio_errors=0.8_r_kind*ratio_errors 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 + if(vqc) then + cg_t=cvar_b(ikx) + cvar=cvar_pg(ikx) else - term = exp_arg - wgt = one - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term + cg_t=zero + cvar=zero endif + if(nvqc) then + ibb=ibeta(ikx) + ikk=ikapa(ikx) + else + ibb=0 + ikk=0 + endif + + call vqc_setup(val,ratio_errors,error,cvar,cg_t,ibb,ikk,& + var_jb,rat_err2,wgt,valqc) + rwgt = wgt/wgtlim if (muse(i)) then ! Accumulate statistics for obs used belonging to this task if(rwgt < one) awork(21) = awork(21)+one @@ -596,6 +588,8 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa my_head%b = cvar_b(ikx) my_head%pg = cvar_pg(ikx) my_head%jb = var_jb + my_head%ib = ibeta(ikx) + my_head%ik = ikapa(ikx) my_head%luse = luse(i) if(oberror_tune) then my_head%kx = ikx ! data type for oberror tuning @@ -778,7 +772,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ @@ -914,8 +911,9 @@ subroutine contents_netcdf_diag_(odiag) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", 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 end subroutine contents_netcdf_diag_ diff --git a/src/gsi/setuppw.f90 b/src/gsi/setuppw.f90 index c588aafb63..b22d4eb661 100644 --- a/src/gsi/setuppw.f90 +++ b/src/gsi/setuppw.f90 @@ -115,7 +115,7 @@ subroutine setuppw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa 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 state_vectors, only: svars3d, levels use sparsearr, only: sparr2, new, size, writearray, fullarray implicit none @@ -167,7 +167,6 @@ subroutine setuppw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa 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 @@ -639,7 +638,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ subroutine contents_binary_diag_(odiag) @@ -756,8 +758,9 @@ subroutine contents_netcdf_diag_(odiag) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", 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 end subroutine contents_netcdf_diag_ diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index aabf55005a..c445bba29f 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -97,6 +97,10 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! 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 +! 2019-05-24 Su - remove current VQC part and add subroutine call and +! add new variational QC option +! ! duplicate obs in twodvar_regional applications ! 2020-01-27 Winterbottom - moved the linear regression derived ! coefficients for the dynamic observation @@ -149,10 +153,11 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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 constants, only: tiny_r_kind,five,half,two,huge_r_kind,r0_01 + use qcmod, only: npres_print,ptopq,pbotq,dfact,dfact1,njqc,vqc,nvqc use jfunc, only: jiter,last,jiterstart,miter use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: ibeta,ikapa use convinfo, only: icsubtype use converr_q, only: ptabl_q use converr, only: ptabl @@ -163,7 +168,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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 + use state_vectors, only: svars3d, levels ! The following variables are the coefficients that describe the ! linear regression fits that are used to define the dynamic @@ -210,7 +215,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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) cg_t,cvar,wgt,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 @@ -231,9 +236,9 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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 + integer(i_kind) ibb,ikk 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 @@ -309,7 +314,6 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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 @@ -660,36 +664,27 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! Compute penalty terms val = error*ddiff + if(nvqc .and. ibeta(ikx) >0 ) ratio_errors=0.8_r_kind*ratio_errors 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 + if(vqc) then + cg_t=cvar_b(ikx) + cvar=cvar_pg(ikx) else - term = exp_arg - wgt =one - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term + cg_t=zero + cvar=zero endif - + if(nvqc) then + ibb=ibeta(ikx) + ikk=ikapa(ikx) + else + ibb=0 + ikk=0 + endif + + call vqc_setup(val,ratio_errors,error,cvar,cg_t,ibb,ikk,& + var_jb,rat_err2,wgt,valqc) + rwgt = wgt/wgtlim ! Accumulate statistics for obs belonging to this task if(muse(i))then if(rwgt < one) awork(21) = awork(21)+one @@ -749,6 +744,8 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head%b = cvar_b(ikx) my_head%pg = cvar_pg(ikx) my_head%jb = var_jb + my_head%ib = ibeta(ikx) + my_head%ik = ikapa(ikx) my_head%luse = luse(i) if(oberror_tune) then @@ -857,6 +854,8 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head%b = cvar_b(ikx) my_head%pg = cvar_pg(ikx) my_head%jb = var_jb + my_head%ib = ibeta(ikx) + my_head%ik = ikapa(ikx) my_head%luse = luse(i) if (luse_obsdiag) then @@ -1052,7 +1051,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ subroutine contents_binary_diag_(odiag) @@ -1231,8 +1233,9 @@ subroutine contents_netcdf_diag_(odiag) 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) + 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 end subroutine contents_netcdf_diag_ @@ -1270,8 +1273,9 @@ subroutine contents_netcdf_diagp_ 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) + 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 end subroutine contents_netcdf_diagp_ diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index b693d668a6..7f001ea9cd 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -214,6 +214,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! 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 +! 2019-08-20 zhu - add flexibility to allow radiances being assimilated without bias correction ! ! input argument list: ! lunin - unit from which to read radiance (brightness temperature, tb) obs @@ -283,9 +284,9 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 qcmod, only: qc_ssmi,qc_geocsr,qc_ssu,qc_avhrr,qc_goesimg,qc_msu,qc_irsnd,qc_amsua,qc_mhs,qc_atms 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, & @@ -294,7 +295,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 state_vectors, only: svars3d, levels, svars2d, ns3d 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 @@ -360,7 +361,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 @@ -380,7 +380,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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):: err2,tbc0,tb_obs0,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 @@ -548,6 +548,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ich(jc)=j do i=1,npred + if (iuse_rad(j)==4) predx(i,j)=zero predchan(i,jc)=predx(i,j) end do ! @@ -997,9 +998,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 + if (iuse_rad(mm)/=4) then + do j=1,angord + cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) + end do + end if end do end if @@ -1172,6 +1175,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& if (retrieval) then call spline_cub(fbias(:,mm),tsavg5,ys_bias_sst) predbias(npred+2,i) = ys_bias_sst + if (iuse_rad(mm)==4) predbias(npred+2,i) = zero endif ! tbc = obs - guess after bias correction @@ -1222,7 +1226,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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(amsua.or.atms) 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) @@ -1422,20 +1426,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 +! ---------- SEVIRI, AHI,ABI ------------------- +! SEVIRI, AHI,ABI Q C - else if (abi) then + else if (seviri .or. abi .or. ahi) then do i=1,nchanl m=ich(i) if (varinv(i) < tiny_r_kind) then @@ -1453,26 +1447,29 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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), & + call qc_geocsr(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) + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,abi,ahi,seviri) 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 + if((abi .or. ahi) .and. i/=2 .and. i/=3) then varinv(i)=zero varinv_use(i)=zero end if + if(seviri .and. i/=2) then + varinv(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( (abi .or. ahi ).and. 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 @@ -1734,6 +1731,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& enddo tbc0=tbc + tb_obs0=tb_obs varinv0 = varinv raterr2 = zero err2 = one/error0**2 @@ -1755,7 +1753,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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) + tbc,tb_obs,err2,raterr2,wgtjo,jacobian,cor_opt,iii,rsqrtinv,rinvdiag) varinv = wgtjo endif endif @@ -2206,9 +2204,10 @@ subroutine init_netcdf_diag_ 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) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif ! call nc_diag_header("Outer_Loop_Iteration", headfix%jiter) ! call nc_diag_header("Satellite_Sensor", headfix%isis) @@ -2305,6 +2304,7 @@ subroutine contents_binary_diag_(odiags,idv,iob) if (.not.microwave) then diagbuf(25) = cld ! cloud fraction (%) diagbuf(26) = cldp ! cloud top pressure (hPa) + if (abi) diagbuf(26) = data_s(32,n) ! cldfrc from bufr else if((radmod%lcloud_fwd .and. sea) .or. gmi .or. amsr2) then diagbuf(25) = clw_obs ! clw (kg/m**2) from retrievals @@ -2344,7 +2344,7 @@ subroutine contents_binary_diag_(odiags,idv,iob) end if do i=1,nchanl_diag - diagbufchan(1,i)=tb_obs(ich_diag(i)) ! observed brightness temperature (K) + diagbufchan(1,i)=tb_obs0(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))) @@ -2359,7 +2359,7 @@ subroutine contents_binary_diag_(odiags,idv,iob) 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 + if(abi .or. ahi .or. seviri) 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 @@ -2509,6 +2509,7 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) 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("Scan_Angle", sngl(data_s(iscan_ang,n)*rad2deg) ) ! scan angle 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 @@ -2572,11 +2573,17 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) 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("Observation", sngl(tb_obs0(ich_diag(i))) ) ! observed brightness temperature (K) call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(tbcnob(ich_diag(i))) ) ! observed - simulated Tb with no bias correction (K) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(tbc0(ich_diag(i) )) ) ! observed - simulated Tb with bias corrrection (K) errinv = sqrt(varinv0(ich_diag(i))) call nc_diag_metadata("Inverse_Observation_Error", sngl(errinv) ) + if (save_jacobian .and. allocated(idnames)) then + call nc_diag_metadata("Observation_scaled", sngl(tb_obs(ich_diag(i))) ) ! observed brightness temperature (K) scaled by R^{-1/2} + call nc_diag_metadata("Obs_Minus_Forecast_adjusted_scaled", sngl(tbc(ich_diag(i) )) ) ! observed - simulated Tb with bias corrrection (K) scaled by R^{-1/2} + errinv = sqrt(varinv(ich_diag(i))) + call nc_diag_metadata("Inverse_Observation_Error_scaled", sngl(errinv) ) + endif if (save_jacobian) then j = 1 do ii = 1, nvarjac @@ -2606,7 +2613,6 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) 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)) diff --git a/src/gsi/setupref.f90 b/src/gsi/setupref.f90 index b4d4265fc6..752cce7e7b 100644 --- a/src/gsi/setupref.f90 +++ b/src/gsi/setupref.f90 @@ -277,6 +277,7 @@ subroutine setupref(obsLL,odiagLL,lunin,mype,awork,nele,nobs,toss_gps_sub,is,ini !44 => PAZ !750-755 => COSMIC-2 Equatorial !724-729 => COSMIC-2 Polar +!5 => MetOpC ! Read and reformat observations in work arrays. read(lunin)data,luse,ioid @@ -578,7 +579,9 @@ subroutine setupref(obsLL,odiagLL,lunin,mype,awork,nele,nobs,toss_gps_sub,is,ini cutoff2=r1em3*trefges**2-r0_455*trefges+r52_075 endif if((ictype(ikx)==41).or.(ictype(ikx)==722).or.(ictype(ikx)==723).or.& - (ictype(ikx)==4).or.(ictype(ikx)==786).or.(ictype(ikx)==3)) then !CL + (ictype(ikx)==4).or.(ictype(ikx)==42).or.(ictype(ikx)==3).or.& + (ictype(ikx)==821).or.(ictype(ikx)==421).or.(ictype(ikx)==440).or.& + (ictype(ikx)==43).or.(ictype(ikx)==786).or.(ictype(ikx)==5)) then !CL cutoff3=(half+two*cos(data(ilate,i)*deg2rad))/three else cutoff3=(one+r2_5*cos(data(ilate,i)*deg2rad))/three @@ -615,7 +618,8 @@ subroutine setupref(obsLL,odiagLL,lunin,mype,awork,nele,nobs,toss_gps_sub,is,ini endif ! Remove MetOP/GRAS data below 8 km - if ((alt <= eight) .and. ((data(isatid,i)==4) .or. (data(isatid,i)==3))) then + if ( (alt <= eight) .and. & + ((data(isatid,i)==4).or.(data(isatid,i)==3).or.(data(isatid,i)==5))) then data(ier,i) = zero ratio_errors(i) = zero qcfail(i)=.true. diff --git a/src/gsi/setuprw.f90 b/src/gsi/setuprw.f90 index 67dbcd248e..543e767714 100644 --- a/src/gsi/setuprw.f90 +++ b/src/gsi/setuprw.f90 @@ -139,7 +139,6 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa 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 implicit none ! Declare passed variables @@ -216,7 +215,6 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa 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 @@ -1067,7 +1065,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ subroutine contents_binary_diag_(odiag) @@ -1188,8 +1189,9 @@ subroutine contents_netcdf_diag_(odiag) 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) + 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 end subroutine contents_netcdf_diag_ diff --git a/src/gsi/setupspd.f90 b/src/gsi/setupspd.f90 index 9f23ee2896..ff01bf5ac6 100644 --- a/src/gsi/setupspd.f90 +++ b/src/gsi/setupspd.f90 @@ -125,7 +125,7 @@ subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags 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 state_vectors, only: svars3d, levels use qcmod, only: dfact,dfact1 use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype use convinfo, only: icsubtype @@ -191,7 +191,6 @@ subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags 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 @@ -850,7 +849,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ subroutine contents_binary_diag_(odiag) @@ -987,8 +989,9 @@ subroutine contents_netcdf_diag_(odiag) 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) + 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 diff --git a/src/gsi/setupsst.f90 b/src/gsi/setupsst.f90 index 78b71837bf..8f1b5dec1c 100644 --- a/src/gsi/setupsst.f90 +++ b/src/gsi/setupsst.f90 @@ -60,6 +60,7 @@ subroutine setupsst(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags ! 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(). +! 2019-11-12 li - add 4 nsst variables to netcdf sst diag file ! ! input argument list: ! lunin - unit from which to read observations @@ -605,6 +606,13 @@ subroutine contents_netcdf_diag_(odiag) 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 (nst_gsi>0) then + call nc_diag_metadata("FoundationTempBG", sngl(data(itref,i)) ) + call nc_diag_metadata("DiurnalWarming_at_zob", sngl(data(idtw,i)) ) + call nc_diag_metadata("SkinLayerCooling_at_zob", sngl(data(idtw,i)) ) + call nc_diag_metadata("Sensitivity_Tzob_Tr", sngl(data(itz_tr,i)) ) + endif if (lobsdiagsave) then do jj=1,miter diff --git a/src/gsi/setupswcp.f90 b/src/gsi/setupswcp.f90 index 0a4152b822..fe61fc40d8 100644 --- a/src/gsi/setupswcp.f90 +++ b/src/gsi/setupswcp.f90 @@ -69,7 +69,7 @@ subroutine setupswcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag 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 state_vectors, only: svars3d, levels use constants, only: zero,one,tpwcon,r1000,r10, & tiny_r_kind,three,half,two,cg_term,huge_single,& @@ -128,7 +128,6 @@ subroutine setupswcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag 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 @@ -809,7 +808,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ @@ -930,8 +932,9 @@ subroutine contents_netcdf_diag_(odiag) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", 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 end subroutine contents_netcdf_diag_ diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index d1bc8a736e..960b73897c 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -45,7 +45,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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 qcmod, only: njqc,vqc,nvqc use oneobmod, only: oneobtest use oneobmod, only: maginnov @@ -57,13 +57,14 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav use guess_grids, only: nfldsig, hrdifsig,ges_lnprsl,& geop_hgtl,ges_tsen,pbl_height - use state_vectors, only: svars3d, levels, nsdim + use state_vectors, only: svars3d, levels 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: tiny_r_kind,half,two 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 convinfo, only: ibeta,ikapa use converr_t, only: ptabl_t use converr, only: ptabl use rapidrefresh_cldsurf_mod, only: l_gsd_terrain_match_surftobs,l_sfcobserror_ramp_t @@ -211,6 +212,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! 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 +! 2019-09-20 Su - remove current VQC part and add subroutine call on VQC with new vqc ! duplicate obs in twodvar_regional applications ! 2020-01-27 Winterbottom - moved the linear regression derived ! coefficients for the dynamic @@ -258,7 +261,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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) cg_t,cvar,wgt,rat_err2,qcgross real(r_kind),dimension(nobs)::dup real(r_kind),dimension(nsig):: prsltmp real(r_kind),dimension(nele,nobs):: data @@ -282,11 +285,11 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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) ibb,ikk 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 @@ -565,10 +568,10 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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) + if (abs(data(ivvlc,i))>=30.0_r_kind) then + pred(2) = 30.0_r_kind + pred(3) = pred(2)*pred(2) + data(ier,i) = 1.5_r_kind*data(ier,i) else pred(2) = data(ivvlc,i) pred(3) = data(ivvlc,i)*data(ivvlc,i) @@ -905,36 +908,29 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! Compute penalty terms val = error*ddiff + if(nvqc .and. ibeta(ikx) >0 ) ratio_errors=0.8_r_kind*ratio_errors 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) + if(vqc) then 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 + cvar=cvar_pg(ikx) else - term = exp_arg - wgt = one - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term + cg_t=zero + cvar=zero endif - + if(nvqc) then + + ibb=ibeta(ikx) + ikk=ikapa(ikx) + else + ibb=0 + ikk=0 + endif + + + call vqc_setup(val,ratio_errors,error,cvar,cg_t,ibb,ikk,& + var_jb,rat_err2,wgt,valqc) + rwgt = wgt/wgtlim ! Accumulate statistics for obs belonging to this task if(muse(i))then if(rwgt < one) awork(21) = awork(21)+one @@ -999,6 +995,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head%b = cvar_b(ikx) my_head%pg = cvar_pg(ikx) my_head%jb = var_jb + my_head%ib = ibeta(ikx) + my_head%ik = ikapa(ikx) my_head%use_sfc_model = sfctype.and.sfcmodel if(my_head%use_sfc_model) then call get_tlm_tsfc(my_head%tlm_tsfc(1), & @@ -1164,6 +1162,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head%b = cvar_b(ikx) my_head%pg = cvar_pg(ikx) my_head%jb = var_jb + my_head%ib = ibeta(ikx) + my_head%ik = ikapa(ikx) my_head%use_sfc_model = sfctype.and.sfcmodel if(my_head%use_sfc_model) then call get_tlm_tsfc(my_head%tlm_tsfc(1), & @@ -1448,7 +1448,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ @@ -1592,7 +1595,7 @@ subroutine contents_netcdf_diag_(odiag) 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("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)) ) @@ -1659,8 +1662,9 @@ subroutine contents_netcdf_diag_(odiag) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", 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 end subroutine contents_netcdf_diag_ @@ -1673,7 +1677,7 @@ subroutine contents_netcdf_diagp_ 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("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)) ) @@ -1698,8 +1702,9 @@ subroutine contents_netcdf_diagp_ 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) + 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 end subroutine contents_netcdf_diagp_ diff --git a/src/gsi/setuptcp.f90 b/src/gsi/setuptcp.f90 index c00daac84f..a63d7a590d 100644 --- a/src/gsi/setuptcp.f90 +++ b/src/gsi/setuptcp.f90 @@ -41,7 +41,7 @@ subroutine setuptcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags ! !$$$ use mpeu_util, only: die,perr,getindex - use state_vectors, only: ns3d, svars2d, levels, nsdim + use state_vectors, only: ns3d, svars2d, levels 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 @@ -118,7 +118,6 @@ subroutine setuptcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags 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 @@ -586,7 +585,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ subroutine contents_binary_diag_(odiag) @@ -698,8 +700,9 @@ subroutine contents_netcdf_diag_(odiag) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", 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 end subroutine contents_netcdf_diag_ diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index a3cad16d75..546ef9d051 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -20,7 +20,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! !USES: use mpeu_util, only: die,perr,getindex - use state_vectors, only: svars3d, levels, nsdim + use state_vectors, only: svars3d, levels use kinds, only: r_kind,r_single,r_double,i_kind use m_obsdiagNode, only: obs_diag use m_obsdiagNode, only: obs_diags @@ -47,19 +47,20 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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 qcmod, only: nvqc 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, & + use constants, only: zero,half,one,tiny_r_kind,two, & 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 convinfo, only: icsubtype,ibeta,ikapa use converr_uv, only: ptabl_uv use converr, only: ptabl use rapidrefresh_cldsurf_mod, only: l_PBL_pseudo_SurfobsUV, pblH_ration,pps_press_incr @@ -207,6 +208,8 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! rather than assuming sensor height is 10 m AGL. ! 2019-08-12 zhang/levine/pondeca - add option to adjust 10-m bckg wind with the help of similarity ! theory in twodvar_regional applications +! 2019-09-20 Su - remove current VQC part and add subroutine call on VQC +! 2019-09-25 Su - put hibert curve on aircraft data ! 2020-01-27 Winterbottom - moved the linear regression derived ! coefficients for the dynamic observation ! error (DOE) calculation to the namelist @@ -248,9 +251,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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) residual,ressw,ress,val,vals,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) cg_t,cvar,wgt,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 @@ -282,6 +285,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav integer(i_kind) ihgt,ier2,iuse,ilate,ilone integer(i_kind) izz,iprvd,isprvd integer(i_kind) idomsfc,isfcr,iskint,iff10 + integer(i_kind) ibb,ikk,ihil integer(i_kind) num_bad_ikx @@ -292,7 +296,6 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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 @@ -316,6 +319,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav real(r_kind) :: hr_offset real(r_kind) :: magomb + equivalence(rstation_id,station_id) equivalence(r_prvstg,c_prvstg) equivalence(r_sprvstg,c_sprvstg) @@ -344,6 +348,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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) @@ -370,8 +375,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav 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 + ihil=26 ! index of hilbert curve weight + iptrbu=27 ! index of u perturbation + iptrbv=28 ! index of v perturbation mm1=mype+1 scale=one @@ -1177,38 +1183,29 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav valu = error*dudiff valv = error*dvdiff - + if(nvqc .and. ibeta(ikx) >0 ) ratio_errors=0.8_r_kind*ratio_errors + ratio_errors=ratio_errors*sqrt(data(ihil,i)) ! hilbert weight ! 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 + vals=sqrt(val) + if(vqc) then + cg_t=cvar_b(ikx) + cvar=cvar_pg(ikx) else - term = exp_arg - wgt = one - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term + cg_t=zero + cvar=zero endif - + if(nvqc) then + ibb=ibeta(ikx) + ikk=ikapa(ikx) + else + ibb=0 + ikk=0 + endif + call vqc_setup(vals,ratio_errors,error,cvar,& + cg_t,ibb,ikk,var_jb,rat_err2,wgt,valqc) + rwgt = wgt/wgtlim ! Accumulate statistics for obs belonging to this task if (muse(i)) then @@ -1285,7 +1282,10 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head%b=cvar_b(ikx) my_head%pg=cvar_pg(ikx) my_head%jb=var_jb + my_head%ib=ibeta(ikx) + my_head%ik=ikapa(ikx) my_head%luse=luse(i) +! if( i==3) print *,'SETUPW',my_head%ures,my_head%vres,my_head%err2 if (luse_obsdiag) then endif ! (luse_obsdiag) @@ -1407,6 +1407,8 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head%b=cvar_b(ikx) my_head%pg=cvar_pg(ikx) my_head%jb=var_jb + my_head%ib=ibeta(ikx) + my_head%ik=ikapa(ikx) my_head%luse=luse(i) if (luse_obsdiag) then @@ -1612,7 +1614,10 @@ subroutine init_netcdf_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 ) + if (save_jacobian) then + call nc_diag_header("jac_nnz", nnz) + call nc_diag_header("jac_nind", nind) + endif endif end subroutine init_netcdf_diag_ subroutine contents_binary_diag_(udiag,vdiag) @@ -1630,7 +1635,7 @@ subroutine contents_binary_diag_(udiag,vdiag) 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(10,ii) = data(ihil,i) ! hilbert curve weight 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) @@ -1817,10 +1822,12 @@ subroutine contents_netcdf_diag_(udiag,vdiag) 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) + call nc_diag_data2d("u_Observation_Operator_Jacobian_stind", dhx_dx_u%st_ind) + call nc_diag_data2d("u_Observation_Operator_Jacobian_endind", dhx_dx_u%end_ind) + call nc_diag_data2d("u_Observation_Operator_Jacobian_val", real(dhx_dx_u%val,r_single)) + call nc_diag_data2d("v_Observation_Operator_Jacobian_stind", dhx_dx_v%st_ind) + call nc_diag_data2d("v_Observation_Operator_Jacobian_endind", dhx_dx_v%end_ind) + call nc_diag_data2d("v_Observation_Operator_Jacobian_val", real(dhx_dx_v%val,r_single)) endif diff --git a/src/gsi/sparsearr.f90 b/src/gsi/sparsearr.f90 index f8f9d41ec6..6c65e1202b 100644 --- a/src/gsi/sparsearr.f90 +++ b/src/gsi/sparsearr.f90 @@ -29,7 +29,7 @@ module sparsearr private public sparr, sparr2 -public new, delete, size +public new, delete, size, raggedarr, init_raggedarr, destroy_raggedarr public writearray, readarray, fullarray public assignment(=) @@ -41,6 +41,11 @@ module sparsearr integer(i_kind), dimension(:), allocatable :: ind ! indices of non-zero elements end type sparr +type raggedarr + integer(i_kind) :: nnz + real(r_kind), dimension(:), allocatable :: val +end type raggedarr + ! sparse array with dense subarrays type ! saves all non-zero elements and start and end indices of the dense ! subarrays @@ -131,6 +136,23 @@ subroutine init_sparr(this, nnz) end subroutine init_sparr +! constructor for raggedarr +subroutine init_raggedarr(this, nnz) + implicit none + type(raggedarr), intent(inout) :: this + integer(i_kind), intent(in) :: nnz + this%nnz = nnz + if (allocated(this%val)) deallocate(this%val) + allocate(this%val(nnz)) +end subroutine init_raggedarr + +! destructor for raggedarr +subroutine destroy_raggedarr(this) + implicit none + type(raggedarr), intent(inout) :: this + if (allocated(this%val)) deallocate(this%val) +end subroutine destroy_raggedarr + ! copying constructor for sparr (from sparr2) subroutine sparr2_to_sparr(this, sp2) type(sparr), intent(inout) :: this diff --git a/src/gsi/stpaod.f90 b/src/gsi/stpaod.f90 index 3afd8b544a..cb76eb9390 100644 --- a/src/gsi/stpaod.f90 +++ b/src/gsi/stpaod.f90 @@ -63,10 +63,8 @@ subroutine stpaod(aerohead,rval,sval,out,sges,nstep) ! !$$$ use kinds, only: r_kind,i_kind,r_quad - use aeroinfo, only: aerojacnames,nsigaerojac,pg_aero,& - b_aero - use qcmod, only: nlnqc_iter,varqc_iter - use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,zero + use aeroinfo, only: aerojacnames,nsigaerojac + use constants, only: half,one,two,zero_quad,zero use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gridmod, only: cmaq_regional,latlon11,nsig diff --git a/src/gsi/stpps.f90 b/src/gsi/stpps.f90 index ecb165bbe7..9016b02dfb 100644 --- a/src/gsi/stpps.f90 +++ b/src/gsi/stpps.f90 @@ -17,6 +17,7 @@ module stppsmod ! 2014-04-12 su - add non linear qc from Purser's scheme ! 2015-02-26 su - add njqc as an option to chose new non linear qc ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2019-09-20 su -remove VQC lines and add to call VQC subroutine ! ! subroutines included: ! sub stpps @@ -78,8 +79,8 @@ subroutine stpps(pshead,rval,sval,out,sges,nstep) ! !$$$ use kinds, only: r_kind,i_kind,r_quad - use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc - use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600 + use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc,nvqc + use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600,zero use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use m_obsNode, only: obsNode @@ -96,9 +97,9 @@ subroutine stpps(pshead,rval,sval,out,sges,nstep) real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges ! Declare local variables - integer(i_kind) j1,j2,j3,j4,kk,ier,istatus + integer(i_kind) j1,j2,j3,j4,kk,ier,istatus,ibb,ikk real(r_kind) val,val2,w1,w2,w3,w4 - real(r_kind) cg_ps,ps,wgross,wnotgross,ps_pg + real(r_kind) cg_t,ps,t_pg,var_jb real(r_kind),dimension(max(1,nstep))::pen real(r_kind),pointer,dimension(:) :: sp real(r_kind),pointer,dimension(:) :: rp @@ -137,34 +138,43 @@ subroutine stpps(pshead,rval,sval,out,sges,nstep) pen(1)=psptr%res*psptr%res*psptr%err2 end if + ! Modify penalty term if nonlinear QC +! EC VQC if (vqc .and. nlnqc_iter .and. psptr%pg > tiny_r_kind .and. & psptr%b > tiny_r_kind) then - ps_pg=psptr%pg*varqc_iter - cg_ps=cg_term/psptr%b - wnotgross= one-ps_pg - wgross =ps_pg*cg_ps/wnotgross - do kk=1,max(1,nstep) - pen(kk) = -two*log((exp(-half*pen(kk))+wgross)/(one+wgross)) - end do + t_pg=psptr%pg*varqc_iter + cg_t=cg_term/psptr%b + else + t_pg=zero + cg_t=zero endif ! for Dr. Jim purser' non liear quality control if(njqc .and. psptr%jb > tiny_r_kind .and. psptr%jb <10.0_r_kind) then - do kk=1,max(1,nstep) - pen(kk) = two*two*psptr%jb*log(cosh(sqrt(pen(kk)/(two*psptr%jb)))) - enddo - out(1) = out(1)+pen(1)*psptr%raterr2 - do kk=2,nstep - out(kk) = out(kk)+(pen(kk)-pen(1))*psptr%raterr2 - end do + var_jb =psptr%jb else - out(1) = out(1)+pen(1)*psptr%raterr2 - do kk=2,nstep - out(kk) = out(kk)+(pen(kk)-pen(1))*psptr%raterr2 - end do + var_jb=zero + endif +! mix model VQC + if(nvqc .and. psptr%ib >0) then + ibb=psptr%ib + ikk=psptr%ik + else + ibb=0 + ikk=0 endif + + + call vqc_stp(pen,nstep,t_pg,cg_t,var_jb,ibb,ikk) + + + out(1) = out(1)+pen(1)*psptr%raterr2 + + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*psptr%raterr2 + end do end if diff --git a/src/gsi/stpq.f90 b/src/gsi/stpq.f90 index 8d87c955a8..f9cabe5d8a 100644 --- a/src/gsi/stpq.f90 +++ b/src/gsi/stpq.f90 @@ -16,6 +16,7 @@ module stpqmod ! 2014-04-12 su - add non linear qc from Purser's scheme ! 2015-02-26 su - add njqc as an option to choose Purser's non-linear qc ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2019-09-20 Su - remove current VQC part and add VQC subroutine call with new vqc ! ! subroutines included: ! sub stpq @@ -77,8 +78,8 @@ subroutine stpq(qhead,rval,sval,out,sges,nstep) ! !$$$ use kinds, only: r_kind,i_kind,r_quad - use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc - use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600 + use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc,nvqc + use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600,zero use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use m_obsNode, only: obsNode @@ -96,8 +97,8 @@ subroutine stpq(qhead,rval,sval,out,sges,nstep) ! Declare local variables integer(i_kind) ier,istatus - integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,kk - real(r_kind) cg_q,val,val2,wgross,wnotgross,q_pg + integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,kk,ibb,ikk + real(r_kind) cg_t,val,val2,t_pg,var_jb real(r_kind),dimension(max(1,nstep))::pen real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8,qq real(r_kind),pointer,dimension(:):: rq,sq @@ -151,29 +152,33 @@ subroutine stpq(qhead,rval,sval,out,sges,nstep) if (vqc .and. nlnqc_iter .and. qptr%pg > tiny_r_kind .and. & qptr%b > tiny_r_kind) then - q_pg=qptr%pg*varqc_iter - cg_q=cg_term/qptr%b - wnotgross= one-q_pg - wgross = q_pg*cg_q/wnotgross - do kk=1,max(1,nstep) - pen(kk)= -two*log((exp(-half*pen(kk))+wgross)/(one+wgross)) - end do + t_pg=qptr%pg*varqc_iter + cg_t=cg_term/qptr%b + else + t_pg=zero + cg_t=zero endif - + +! for Dr. Jim purser' non liear quality control if(njqc .and. qptr%jb > tiny_r_kind .and. qptr%jb <10.0_r_kind) then - do kk=1,max(1,nstep) - pen(kk) = two*two*qptr%jb*log(cosh(sqrt(pen(kk)/(two*qptr%jb)))) - enddo - out(1) = out(1)+pen(1)*qptr%raterr2 - do kk=2,nstep - out(kk) = out(kk)+(pen(kk)-pen(1))*qptr%raterr2 - end do + var_jb =qptr%jb else - out(1) = out(1)+pen(1)*qptr%raterr2 - do kk=2,nstep - out(kk) = out(kk)+(pen(kk)-pen(1))*qptr%raterr2 - end do + var_jb=zero + endif +! mix model VQC + if(nvqc .and. qptr%ib >0) then + ibb=qptr%ib + ikk=qptr%ik + else + ibb=0 + ikk=0 endif + call vqc_stp(pen,nstep,t_pg,cg_t,var_jb,ibb,ikk) + + out(1) = out(1)+pen(1)*qptr%raterr2 + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*qptr%raterr2 + end do end if diff --git a/src/gsi/stpt.f90 b/src/gsi/stpt.f90 index 93807646d7..f793c6a214 100644 --- a/src/gsi/stpt.f90 +++ b/src/gsi/stpt.f90 @@ -16,6 +16,7 @@ module stptmod ! 2014-04-12 su - add non linear qc from Purser's scheme ! 2015-02-26 su - add njqc as an option to choos new non linear qc ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2019-09-20 Su - remove current VQC part and add VQC subroutine call ! ! subroutines included: ! sub stpt @@ -99,7 +100,7 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) ! !$$$ use kinds, only: r_kind,i_kind,r_quad - use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc + use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc,nvqc use constants, only: zero,half,one,two,tiny_r_kind,cg_term,zero_quad,r3600 use aircraftinfo, only: npredt,ntail,aircraft_t_bc_pof,aircraft_t_bc use gsi_bundlemod, only: gsi_bundle @@ -123,7 +124,7 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) integer(i_kind) ier,istatus,isst integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,kk,n,ix real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8 - real(r_kind) cg_t,val,val2,wgross,wnotgross,t_pg + real(r_kind) cg_t,val,val2,t_pg,var_jb real(r_kind),dimension(max(1,nstep))::pen,tt real(r_kind) tg_prime,valq,valq2,valp,valp2,valu,valu2 real(r_kind) ts_prime,valv,valv2,valsst,valsst2 @@ -131,6 +132,7 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) real(r_kind) us_prime real(r_kind) vs_prime real(r_kind) psfc_prime + integer(i_kind) ibb,ikk type(tNode), pointer :: tptr real(r_kind),pointer,dimension(:) :: rt,st,rtv,stv,rq,sq,ru,su,rv,sv real(r_kind),pointer,dimension(:) :: rsst,ssst @@ -254,35 +256,40 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) end do ! Modify penalty term if nonlinear QC - - if (vqc .and. nlnqc_iter .and. tptr%pg > tiny_r_kind .and. tptr%b >tiny_r_kind) then +! EC VQc + if (vqc .and. nlnqc_iter .and. tptr%pg > tiny_r_kind & + .and. tptr%b >tiny_r_kind) then t_pg=tptr%pg*varqc_iter cg_t=cg_term/tptr%b - wnotgross= one-t_pg - wgross =t_pg*cg_t/wnotgross - do kk=1,max(1,nstep) - pen(kk) = -two*log((exp(-half*pen(kk))+wgross)/(one+wgross)) - end do + else + t_pg=zero + cg_t=zero endif -! Note: if wgross=0 (no gross error, then wnotgross=1 and this all -! reduces to the linear case (no qc) ! Jim Purse's non linear QC scheme if(njqc .and. tptr%jb > tiny_r_kind .and. tptr%jb <10.0_r_kind) then - do kk=1,max(1,nstep) - pen(kk) = two*two*tptr%jb*log(cosh(sqrt(pen(kk)/(two*tptr%jb)))) - enddo - out(1) = out(1)+pen(1)*tptr%raterr2 - do kk=2,nstep - out(kk) = out(kk)+(pen(kk)-pen(1))*tptr%raterr2 - end do + var_jb =tptr%jb else - out(1) = out(1)+pen(1)*tptr%raterr2 - do kk=2,nstep - out(kk) = out(kk)+(pen(kk)-pen(1))*tptr%raterr2 - end do + var_jb=zero endif + +! mix model VQC + if(nvqc .and. tptr%ib >0) then + ibb=tptr%ib + ikk=tptr%ik + else + ibb=0 + ikk=0 + endif + + + call vqc_stp(pen,nstep,t_pg,cg_t,var_jb,ibb,ikk) + + out(1) = out(1)+pen(1)*tptr%raterr2 + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*tptr%raterr2 + end do endif tptr => tNode_nextcast(tptr) diff --git a/src/gsi/stpw.f90 b/src/gsi/stpw.f90 index cbe0c5914d..ee1569d731 100644 --- a/src/gsi/stpw.f90 +++ b/src/gsi/stpw.f90 @@ -16,6 +16,7 @@ module stpwmod ! 2014-04-12 su - add non linear qc from Purser's scheme ! 2015-02-26 su - add njqc as an option to chose new non linear qc ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2019-05-31 Su - remove current VQC part and add VQC subroutine call ! ! subroutines included: ! sub stpw @@ -81,8 +82,8 @@ subroutine stpw(whead,rval,sval,out,sges,nstep) ! !$$$ use kinds, only: r_kind,i_kind,r_quad - use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc - use constants, only: one,half,two,tiny_r_kind,cg_term,zero_quad,r3600 + use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc,nvqc + use constants, only: one,half,two,tiny_r_kind,cg_term,zero_quad,r3600,zero use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use m_obsNode, only: obsNode @@ -99,10 +100,10 @@ subroutine stpw(whead,rval,sval,out,sges,nstep) real(r_kind),dimension(max(1,nstep)),intent(in):: sges ! Declare local variables - integer(i_kind) ier,istatus + integer(i_kind) ier,istatus,ibb,ikk integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,kk real(r_kind) valu,facu,valv,facv,w1,w2,w3,w4,w5,w6,w7,w8 - real(r_kind) cg_w,wgross,wnotgross,w_pg + real(r_kind) cg_t,t_pg,var_jb real(r_kind) uu,vv real(r_kind),dimension(max(1,nstep))::pen real(r_kind),pointer,dimension(:):: ru,rv,su,sv @@ -164,32 +165,38 @@ subroutine stpw(whead,rval,sval,out,sges,nstep) ! Modify penalty term if nonlinear QC - if (vqc .and. nlnqc_iter .and. wptr%pg > tiny_r_kind .and. & + if (vqc .and. nlnqc_iter .and. wptr%pg > tiny_r_kind .and. & wptr%b > tiny_r_kind) then - w_pg=wptr%pg*varqc_iter - cg_w=cg_term/wptr%b - wnotgross= one-w_pg - wgross =w_pg*cg_w/wnotgross - do kk=1,max(1,nstep) - pen(kk)= -two*log((exp(-half*pen(kk))+wgross)/(one+wgross)) - end do + t_pg=wptr%pg*varqc_iter + cg_t=cg_term/wptr%b + else + t_pg=zero + cg_t=zero endif -! Purser's scheme - if(njqc .and. wptr%jb > tiny_r_kind .and. wptr%jb <10.0_r_kind) then - do kk=1,max(1,nstep) - pen(kk) = two*two*wptr%jb*log(cosh(sqrt(pen(kk)/(two*wptr%jb)))) - enddo - out(1) = out(1)+pen(1)*wptr%raterr2 - do kk=2,nstep - out(kk) = out(kk)+(pen(kk)-pen(1))*wptr%raterr2 - end do +! for Dr. Jim purser' non liear quality control + if(njqc .and. wptr%jb > tiny_r_kind .and. wptr%jb <10.0_r_kind) then + var_jb =wptr%jb else - out(1) = out(1)+pen(1)*wptr%raterr2 - do kk=2,nstep - out(kk) = out(kk)+(pen(kk)-pen(1))*wptr%raterr2 - end do + var_jb=zero endif +! mix model VQC + if(nvqc .and. wptr%ib >0) then + ibb=wptr%ib + ikk=wptr%ik + else + ibb=0 + ikk=0 + endif + + + call vqc_stp(pen,nstep,t_pg,cg_t,var_jb,ibb,ikk) + + out(1) = out(1)+pen(1)*wptr%raterr2 + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*wptr%raterr2 + end do + end if wptr => wNode_nextcast(wptr) diff --git a/src/gsi/vqc_int.f90 b/src/gsi/vqc_int.f90 new file mode 100644 index 0000000000..714ee23ea3 --- /dev/null +++ b/src/gsi/vqc_int.f90 @@ -0,0 +1,60 @@ + subroutine vqc_int(error2,rat_error2,t_pgv,cg_tv,var_jbv,ibv,ikv,valv,gradv) + +! $$$ documentation block +! +! prgmmr: X.Su date: 2019-05-29 +! +! +! abstract: Variational package to be called by int subroutines. +! +! program history log: +! +! 2019-05-29 Su +! +! $$$ + + use kinds, only: r_kind,i_kind + use constants, only: half,one,two,tiny_r_kind + use qcmod, only: nlnqc_iter,njqc,vqc,nvqc,hub_norm + use pvqc, only: vqch,vqcs + + implicit none +! !INPUT PARAMETERS: + real(r_kind), intent(in ) :: t_pgv,cg_tv,var_jbv,rat_error2,error2 + integer(i_kind), intent(in ) :: ibv,ikv +! INPUT/OUTPUT PARAMETERS: + real(r_kind), intent(inout) :: valv + real(r_kind), intent(out) :: gradv +! Declare local variables + + real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq + + + + + if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. & + cg_tv > tiny_r_kind) then + wnotgross= one-t_pgv + wgross =t_pgv*cg_tv/wnotgross + p0=wgross/(wgross+exp(-half*error2*valv**2)) + valv=valv*(one-p0) + gradv = valv*rat_error2*error2 + else if (njqc .and. var_jbv > tiny_r_kind .and. var_jbv <10.0_r_kind) then + valv=sqrt(two*var_jbv)*tanh(sqrt(error2)*valv/sqrt(two*var_jbv)) + gradv = valv*rat_error2*sqrt(error2) + else if (nvqc .and. ibv >0) then + qq=valv*sqrt(error2) + if(hub_norm) then + call vqch(ibv,ikv,qq,g_nvqc,w_nvqc) + else + call vqcs(ibv,ikv,qq,g_nvqc,w_nvqc) + endif + gradv=w_nvqc*qq*sqrt(error2)*rat_error2 + else + gradv = valv*rat_error2*error2 + endif + + + + return + end subroutine vqc_int diff --git a/src/gsi/vqc_setup.f90 b/src/gsi/vqc_setup.f90 new file mode 100644 index 0000000000..1579961335 --- /dev/null +++ b/src/gsi/vqc_setup.f90 @@ -0,0 +1,112 @@ +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI +! ! +!------------------------------------------------------------------------- +!BOP +! +! !ROUTINE: vqc_setup ---the subroutine to calculate all the penalties called in setup routine +! +! !INTERFACE: + + subroutine vqc_setup(vals,ratio_err,obserr,cvar_pgv,cvar_bv,ibv,ikv,var_jbv,rat_err2,wgt,valqc_v) + +! subprogram: vqc_setup +! prgmmr: Su, Xiujuan Date: 2019-05-22 +! !DESCRIPTION: The subroutine calculate penalties depending input which variational +! qc scheme we use, this part is used to be in setup +! routines. You can call this subroutine to get +! penalties and weight for different variational QC +! schemes. +! input parameters: +! vals :the difference of observation and background normalied by error. +! ratio_err:adjusted factor of error due to various qc or time. +! obserr : observation erro. +! cvar_pgv : a parameter for ECMWF VQC +! cvar_bv : a parameter for ECMWF VQC. +! ibv : a parameter for Hubert Norm and logistic VQC, betta. +! ikv : a parameter for Hubert Norm and logistic VQC, kappa. +! var_jbv : a parameter for logistic VQC:b. +! +! output parameter: +! wgt : weight when applied VQC <=1. +! valqc_v : penalties +! rat_err2: adjusted error facter square +!! USES + + use kinds, only: r_kind,r_single,r_double,i_kind + use constants, only: tiny_r_kind,half,two,cg_term + use constants,only: zero,one,two + use qcmod,only: njqc,vqc,nvqc,hub_norm + + use pvqc, only: vqch,vqcs + + implicit none + +! !INPUT PARAMETERS: + + real(r_kind), intent(in ) :: vals,obserr,cvar_pgv,cvar_bv,var_jbv + integer(i_kind), intent(in ) :: ibv,ikv + +! INPUT/OUTPUT PARAMETERS: + + real(r_kind), intent(in) :: ratio_err + +! OUTPUT PARAMETERS: + + real(r_kind), intent(out) :: wgt,valqc_v,rat_err2 + + +! !REVISION HISTORY: + +! 2019-05-23 X. Su + + + +! Declare local variables + + real(r_kind) val2,term,arg,exp_arg + + real(r_kind) wnotgross,cg_t,wgross + real(r_kind) g_nvqc,w_nvqc + + + val2 = vals*vals + exp_arg = -half*val2 + rat_err2 = ratio_err**2 + if(njqc .and. var_jbv>tiny_r_kind .and. var_jbv < 10.0_r_kind .and. obserr >tiny_r_kind) then + if(exp_arg == zero) then + wgt=one + else + wgt=vals/sqrt(two*var_jbv) + wgt=tanh(wgt)/wgt + endif + term=-two*var_jbv*rat_err2*log(cosh((vals)/sqrt(two*var_jbv))) + valqc_v = -two*term + else if (vqc .and. cvar_pgv> tiny_r_kind .and.obserr >tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pgv + cg_t=cvar_bv + wgross = cg_term*cvar_pgv/(cg_t*wnotgross) + term =log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + valqc_v = -two*rat_err2*term + else if(nvqc .and. ibv >0) then + if(hub_norm) then + call vqch(ibv,ikv,vals,g_nvqc,w_nvqc) + else + call vqcs(ibv,ikv,vals,g_nvqc,w_nvqc) + endif + valqc_v=-two*rat_err2*g_nvqc + if(vals ==zero) then + wgt=one + else + wgt=g_nvqc/exp_arg + endif + else + term = exp_arg + wgt = one + valqc_v = -two*rat_err2*term + endif + + return + end subroutine vqc_setup diff --git a/src/gsi/vqc_stp.f90 b/src/gsi/vqc_stp.f90 new file mode 100644 index 0000000000..1c8f296853 --- /dev/null +++ b/src/gsi/vqc_stp.f90 @@ -0,0 +1,67 @@ + subroutine vqc_stp(pen_v,nstep_v,tpg_v,cgt_v,& + var_jbv,ibv,ikv) + +! subprogram: vqc_stpt +! prgmmr: Su, Xiujuan Date: 2019-05-23 +!! !DESCRIPTION: The subroutine calculate modified penalties in every +! iteration for different variational QC schemes. the +! subroutine is called by stp routines. +! +! +! +! +! +! +! USES + + use kinds, only: r_kind,r_single,r_double,i_kind + use constants, only: tiny_r_kind,half,two,one + use qcmod, only: nlnqc_iter,njqc,vqc,nvqc,hub_norm + use pvqc, only: vqch,vqcs + + implicit none +! !INPUT PARAMETERS: + + real(r_kind), intent(in ) :: tpg_v,cgt_v,var_jbv + integer(i_kind), intent(in ) :: ibv,ikv,nstep_v + +! INPUT/OUTPUT PARAMETERS: + + real(r_kind),dimension(max(1,nstep_v)),intent(inout)::pen_v + +! Declare local variables + + real(r_kind) wnotgross,wgross,qq,g_nvqc,w_nvqc + integer kk + + + + +! Declare passed variables +! Note: if wgross=0 (no gross error, then wnotgross=1 and this +! all reduces to the linear case (no qc) + + if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then + wnotgross= one-tpg_v + wgross =tpg_v*cgt_v/wnotgross + do kk=1,max(1,nstep_v) + pen_v(kk) = -two*log((exp(-half*pen_v(kk))+wgross)/(one+wgross)) + end do + else if (nvqc .and. ibv >0) then ! new variational qc + do kk=1,max(1,nstep_v) + qq=sqrt(pen_v(kk)) + if(hub_norm) then + call vqch(ibv,ikv,qq,g_nvqc,w_nvqc) + else + call vqcs(ibv,ikv,qq,g_nvqc,w_nvqc) + endif + pen_v(kk)=-two*g_nvqc + enddo + else if(njqc .and. var_jbv > tiny_r_kind .and. var_jbv <10.0_r_kind) then + do kk=1,max(1,nstep_v) + pen_v(kk) = two*two*var_jbv*log(cosh(sqrt(pen_v(kk)/(two*var_jbv)))) + enddo + endif + + return + end subroutine vqc_stp diff --git a/src/gsi/write_all.F90 b/src/gsi/write_all.F90 index 0e7569232d..89483251d7 100644 --- a/src/gsi/write_all.F90 +++ b/src/gsi/write_all.F90 @@ -36,10 +36,12 @@ subroutine write_all(increment) use ncepgfs_io, only: write_gfs - use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: gsi_bundle, gsi_bundlegetpointer use gsi_metguess_mod, only: gsi_metguess_bundle use mpeu_util, only: die + + use control_vectors, only: control_vector implicit none diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90 new file mode 100644 index 0000000000..eae5c5ffe4 --- /dev/null +++ b/src/gsi/write_incr.f90 @@ -0,0 +1,562 @@ +module write_incr +!$$$ module documentation block +! . . . . +! module: write_incr +! prgmmr: Martin org: date: 2019-09-04 +! +! abstract: This module contains routines which write out +! the atmospheric increment rather than analysis +! +! program history log: +! 2019-09-04 Martin Initial version. Based on ncepnems_io +! 2019-09-13 martin added option to zero out certain increment fields +! +! Subroutines Included: +! sub write_fv3_increment - writes netCDF increment for FV3 global model +! +!$$$ end documentation block + + implicit none + private + public write_fv3_increment + + interface write_fv3_increment + module procedure write_fv3_inc_ + end interface + +contains + + subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) + +!$$$ subprogram documentation block +! . . . +! subprogram: write_fv3_increment +! +! prgmmr: Martin org: date: 2019-09-04 +! +! abstract: This routine takes GSI analysis increments and writes +! to a netCDF file on the analysis resolution for use by FV3-GFS +! +! program history log: +! 2019-09-04 martin Initial version. Based on write_atm_nemsio +! 2019-09-13 martin added option to zero out certain increment fields +! 2020-01-10 martin added in parallel write to decrease wallclock time +! +! 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 netcdf, only: & + nf90_netcdf4,nf90_mpiio,nf90_create,nf90_def_dim,nf90_real,nf90_def_var,& + nf90_collective,nf90_var_par_access,nf90_global,nf90_put_att,nf90_put_att,& + nf90_enddef,nf90_put_var,nf90_close,nf90_noerr,nf90_strerror + + use kinds, only: r_kind,i_kind + + use mpimod, only: mpi_rtype + use mpimod, only: mpi_comm_world, mpi_info_null + use mpimod, only: ierror + use mpimod, only: mype + + use gridmod, only: strip, rlats, rlons, bk5 + use gridmod, only: istart, jstart + + use general_specmod, only: spec_vars + use general_sub2grid_mod, only: sub2grid_info + + use gsi_bundlemod, only: gsi_bundle, gsi_bundlegetpointer + use control_vectors, only: control_vector + + use constants, only: one, rad2deg, r1000 + + use gsi_4dcouplermod, only : gsi_4dcoupler_grtests + use gsi_4dvar, only: nobs_bins, l4dvar, nsubwin, l4densvar + use hybrid_ensemble_parameters, only: l_hyb_ens, ntlevs_ens + use bias_predictors, only: predictors, allocate_preds, deallocate_preds + use jfunc, only: xhatsave, iter + + use guess_grids, only: load_geop_hgt, geop_hgti, ges_geopi, ges_tsen, ges_tsen1,& + ges_q1, ifilesig + use obsmod, only: ianldate + use state_vectors, only: allocate_state, deallocate_state + + 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),pointer,dimension(:,:,:) :: sub_u,sub_v + real(r_kind),pointer,dimension(:,:,:) :: sub_qanl,sub_oz + real(r_kind),pointer,dimension(:,:,:) :: sub_ql, sub_qi + real(r_kind),pointer,dimension(:,:) :: sub_ps + + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig) :: sub_dzb,sub_dza, sub_tsen, sub_q + + real(r_kind),dimension(grd%lat1,grd%lon1) :: pssm + real(r_kind),dimension(grd%lat1,grd%lon1,grd%nsig):: tsensm, usm, vsm + real(r_kind),dimension(grd%lat1,grd%lon1,grd%nsig):: qsm, ozsm + real(r_kind),dimension(grd%lat1,grd%lon1,grd%nsig):: qism, qlsm + real(r_kind),dimension(grd%lat1,grd%lon1,grd%nsig):: dzsm + real(r_kind),dimension(grd%lat1,grd%lon1,grd%nsig):: delp + real(r_kind),dimension(grd%nlon) :: deglons + real(r_kind),dimension(grd%nlat-2) :: deglats + real(r_kind),dimension(grd%nsig) :: levsout + real(r_kind),dimension(grd%nsig+1) :: ilevsout + + integer(i_kind) :: mm1, i, j, k, iii, krev + integer(i_kind) :: iret, istatus + integer(i_kind) :: ibin2 + integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid + integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & + hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & + tvarid, sphumvarid, liqwatvarid, o3varid, icvarid + integer(i_kind) :: dimids3(3),nccount(3),ncstart(3), cnksize(3), j1, j2 + + type(gsi_bundle) :: svalinc(nobs_bins) + type(gsi_bundle) :: evalinc(ntlevs_ens) + type(gsi_bundle) :: mvalinc(nsubwin) + type(predictors) :: sbiasinc + logical llprt + + integer(i_kind),dimension(grd%lat1,grd%lon1) :: troplev + + real(r_kind), allocatable, dimension(:,:,:) :: out3d + + +!************************************************************************* +! Initialize local variables + mm1=mype+1 + llprt=(mype==0).and.(iter<=1) + ibin2 = ibin + if (.not. l4densvar) ibin2 = 1 + +! set up state space based off of xhatsave +! Convert from control space directly to physical +! space for comparison with obs. + call allocate_preds(sbiasinc) + do iii=1,nobs_bins + call allocate_state(svalinc(iii)) + end do + do iii=1,nsubwin + call allocate_state(mvalinc(iii)) + end do + do iii=1,ntlevs_ens + call allocate_state(evalinc(iii)) + end do + call control2state(xhatsave,mvalinc,sbiasinc) + + if (l4dvar) then + if (l_hyb_ens) then + call ensctl2state(xhatsave,mvalinc(1),evalinc) + mvalinc(1)=evalinc(1) + end if + +! Perform test of AGCM TLM and ADM + call gsi_4dcoupler_grtests(mvalinc,svalinc,nsubwin,nobs_bins) + +! Run TL model to fill sval + call model_tl(mvalinc,svalinc,llprt) + else + if (l_hyb_ens) then + call ensctl2state(xhatsave,mvalinc(1),evalinc) + do iii=1,nobs_bins + svalinc(iii)=evalinc(iii) + end do + else + do iii=1,nobs_bins + svalinc(iii)=mvalinc(1) + end do + end if + end if + + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'q', sub_qanl, iret); istatus=istatus+iret + call gsi_bundlegetpointer(svalinc(ibin2),'ql', sub_ql, iret); istatus=istatus+iret + call gsi_bundlegetpointer(svalinc(ibin2),'qi', sub_qi, iret); istatus=istatus+iret + call gsi_bundlegetpointer(svalinc(ibin2),'oz', sub_oz, iret); istatus=istatus+iret + call gsi_bundlegetpointer(svalinc(ibin2),'u', sub_u, iret); istatus=istatus+iret + call gsi_bundlegetpointer(svalinc(ibin2),'v', sub_v, iret); istatus=istatus+iret + call gsi_bundlegetpointer(svalinc(ibin2),'ps', sub_ps, iret); istatus=istatus+iret ! needed for delp + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'write_fv3_incr_: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + end if + + ! create the output netCDF file + call nccheck_incr(nf90_create(path=trim(filename)//".nc", cmode=ior(nf90_netcdf4, nf90_mpiio), ncid=ncid_out, & + comm = mpi_comm_world, info = mpi_info_null)) + ! create dimensions based on analysis resolution, not guess + call nccheck_incr(nf90_def_dim(ncid_out, "lon", grd%nlon, lon_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "lat", grd%nlat-2, lat_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "lev", grd%nsig, lev_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "ilev", grd%nsig+1, ilev_dimid)) + dimids3 = (/ lon_dimid, lat_dimid, lev_dimid /) + cnksize = (/ grd%lon1, grd%lat1, grd%nsig /) + ! create variables + call nccheck_incr(nf90_def_var(ncid_out, "lon", nf90_real, (/lon_dimid/), lonvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "lat", nf90_real, (/lat_dimid/), latvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "lev", nf90_real, (/lev_dimid/), levvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "pfull", nf90_real, (/lev_dimid/), pfullvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "ilev", nf90_real, (/ilev_dimid/), ilevvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "hyai", nf90_real, (/ilev_dimid/), hyaivarid)) + call nccheck_incr(nf90_def_var(ncid_out, "hybi", nf90_real, (/ilev_dimid/), hybivarid)) + call nccheck_incr(nf90_def_var(ncid_out, "u_inc", nf90_real, dimids3, uvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, uvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "v_inc", nf90_real, dimids3, vvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, vvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "delp_inc", nf90_real, dimids3, delpvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, delpvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "delz_inc", nf90_real, dimids3, delzvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, delzvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "T_inc", nf90_real, dimids3, tvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, tvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "sphum_inc", nf90_real, dimids3, sphumvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, sphumvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "liq_wat_inc", nf90_real, dimids3, liqwatvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, liqwatvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "o3mr_inc", nf90_real, dimids3, o3varid)) + call nccheck_incr(nf90_var_par_access(ncid_out, o3varid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "icmr_inc", nf90_real, dimids3, icvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, icvarid, nf90_collective)) + ! place global attributes to parallel calc_increment output + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & + "global analysis increment from write_fv3_increment")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time", ianldate)) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "IAU_hour_from_guess", ifilesig(ibin))) + ! add units to lat/lon because that's what the calc_increment utility has + call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units", "degrees_east")) + call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units", "degrees_north")) + ! end the netCDF file definition + call nccheck_incr(nf90_enddef(ncid_out)) + + ! compute delz + do k=1,grd%nsig + sub_dzb(:,:,k) = ges_geopi(:,:,k+1,ibin) - ges_geopi(:,:,k,ibin) + enddo + + 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 + + ! compute sensible T increment + sub_tsen = ges_tsen(:,:,:,ibin) - ges_tsen1(:,:,:,ibin) + + ! compute q increment + sub_q = sub_qanl(:,:,:) - ges_q1(:,:,:,ibin) + + ! Strip off boundary points from subdomains + call strip(sub_tsen ,tsensm ,grd%nsig) + call strip(sub_q ,qsm ,grd%nsig) + call strip(sub_ql ,qlsm ,grd%nsig) + call strip(sub_qi ,qism ,grd%nsig) + call strip(sub_oz ,ozsm ,grd%nsig) + call strip(sub_ps ,pssm ) + call strip(sub_u ,usm ,grd%nsig) + call strip(sub_v ,vsm ,grd%nsig) + call strip(sub_dza, dzsm, grd%nsig) + + if (mype == mype_out) then + ! latitudes + do j=2,grd%nlat-1 + deglats(j-1) = rlats(j)*rad2deg + end do + ! write to file + call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, & + start = (/1/), count = (/grd%nlat-2/))) + ! longitudes + do i=1,grd%nlon + deglons(i) = rlons(i)*rad2deg + end do + ! write to file + call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, & + start = (/1/), count = (/grd%nlon/))) + ! levels + do k=1,grd%nsig + levsout(k) = float(k) + ilevsout(k) = float(k) + end do + ilevsout(grd%nsig+1) = float(grd%nsig+1) + ! write to file + call nccheck_incr(nf90_put_var(ncid_out, levvarid, sngl(levsout), & + start = (/1/), count = (/grd%nsig/))) + ! pfull + call nccheck_incr(nf90_put_var(ncid_out, pfullvarid, sngl(levsout), & + start = (/1/), count = (/grd%nsig/))) + ! ilev + call nccheck_incr(nf90_put_var(ncid_out, ilevvarid, sngl(ilevsout), & + start = (/1/), count = (/grd%nsig+1/))) + ! hyai + call nccheck_incr(nf90_put_var(ncid_out, hyaivarid, sngl(ilevsout), & + start = (/1/), count = (/grd%nsig+1/))) + ! hybi + call nccheck_incr(nf90_put_var(ncid_out, hybivarid, sngl(ilevsout), & + start = (/1/), count = (/grd%nsig+1/))) + end if + + ! get levels that are nearest the tropopause pressure + call get_troplev(troplev,ibin) + + j1 = 1 + j2 = grd%lat1 + ncstart = (/ jstart(mype+1), istart(mype+1)-1, 1 /) + nccount = (/ grd%lon1, grd%lat1, grd%nsig /) + if (istart(mype+1) == 1) then + ncstart = (/ jstart(mype+1), 1, 1 /) + nccount = (/ grd%lon1, grd%lat1-1, grd%nsig /) + j1 = 2 + j2 = grd%lat1-1 + else if (istart(mype+1)+grd%lat1 == grd%nlat+1) then + nccount = (/ grd%lon1, grd%lat1-1, grd%nsig /) + j2 = grd%lat1-2 + end if + call mpi_barrier(mpi_comm_world,ierror) + allocate(out3d(nccount(1),nccount(2),grd%nsig)) + ! u increment + do k=1,grd%nsig + krev = grd%nsig+1-k + if (zero_increment_strat('u_inc')) then + call zero_inc_strat(usm(:,:,k), k, troplev) + end if + if (should_zero_increments_for('u_inc')) usm(:,:,k) = 0.0_r_kind + out3d(:,:,krev) = transpose(usm(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, uvarid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) +! ! v increment + do k=1,grd%nsig + krev = grd%nsig+1-k + if (zero_increment_strat('v_inc')) then + call zero_inc_strat(vsm(:,:,k), k, troplev) + end if + if (should_zero_increments_for('v_inc')) vsm(:,:,k) = 0.0_r_kind + out3d(:,:,krev) = transpose(vsm(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, vvarid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) +! ! delp increment + do k=1,grd%nsig + krev = grd%nsig+1-k + delp(:,:,k) = pssm * (bk5(k)-bk5(k+1)) * r1000 + if (should_zero_increments_for('delp_inc')) delp(:,:,k) = 0.0_r_kind + if (zero_increment_strat('delp_inc')) call zero_inc_strat(delp(:,:,k), k, troplev) + out3d(:,:,krev) = transpose(delp(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, delpvarid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) + ! delz increment + do k=1,grd%nsig + krev = grd%nsig+1-k + if (zero_increment_strat('delz_inc')) then + call zero_inc_strat(dzsm(:,:,k), k, troplev) + end if + if (should_zero_increments_for('delz_inc')) dzsm(:,:,k) = 0.0_r_kind + out3d(:,:,krev) = transpose(dzsm(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, delzvarid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) + ! Temperature Increment + do k=1,grd%nsig + krev = grd%nsig+1-k + if (zero_increment_strat('T_inc')) then + call zero_inc_strat(tsensm(:,:,k), k, troplev) + end if + if (should_zero_increments_for('T_inc')) tsensm(:,:,k) = 0.0_r_kind + out3d(:,:,krev) = transpose(tsensm(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, tvarid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) + ! specific humidity increment + do k=1,grd%nsig + krev = grd%nsig+1-k + if (zero_increment_strat('sphum_inc')) then + call zero_inc_strat(qsm(:,:,k), k, troplev) + end if + if (should_zero_increments_for('sphum_inc')) qsm(:,:,k) = 0.0_r_kind + out3d(:,:,krev) = transpose(qsm(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, sphumvarid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) + ! liquid water increment + do k=1,grd%nsig + krev = grd%nsig+1-k + if (zero_increment_strat('liq_wat_inc')) then + call zero_inc_strat(qlsm(:,:,k), k, troplev) + end if + if (should_zero_increments_for('liq_wat_inc')) qlsm(:,:,k) = 0.0_r_kind + out3d(:,:,krev) = transpose(qlsm(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) + ! ozone increment + do k=1,grd%nsig + krev = grd%nsig+1-k + if (zero_increment_strat('o3mr_inc')) then + call zero_inc_strat(ozsm(:,:,k), k, troplev) + end if + if (should_zero_increments_for('o3mr_inc')) ozsm(:,:,k) = 0.0_r_kind + out3d(:,:,krev) = transpose(ozsm(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, o3varid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) + ! ice mixing ratio increment + do k=1,grd%nsig + krev = grd%nsig+1-k + if (zero_increment_strat('icmr_inc')) then + call zero_inc_strat(qism(:,:,k), k, troplev) + end if + if (should_zero_increments_for('icmr_inc')) qism(:,:,k) = 0.0_r_kind + out3d(:,:,krev) = transpose(qism(j1:j2,:,k)) + end do + call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(out3d), & + start = ncstart, count = nccount)) + call mpi_barrier(mpi_comm_world,ierror) +! ! cleanup and exit + call nccheck_incr(nf90_close(ncid_out)) + if ( mype == mype_out ) then + write(6,*) "FV3 netCDF increment written, file= "//trim(filename)//".nc" + end if + + end subroutine write_fv3_inc_ + + !======================================================================= + subroutine get_troplev(troplev,ifldsig) + ! find the model level that is first above the tropopause pressure + use guess_grids, only: tropprs, ges_prsl + use gridmod, only: lat1, lon1, nsig + use kinds, only: i_kind, r_kind + implicit none + integer(i_kind), intent(in ) :: ifldsig + integer(i_kind),dimension(lat1,lon1), intent( out) :: troplev + integer(i_kind) :: i,j,k + do j=1,lat1 + do i=1,lon1 + do k=1,nsig + if (ges_prsl(j+1,i+1,k,ifldsig)*10.0_r_kind <= tropprs(j+1,i+1)) then + troplev(j,i) = k + exit + end if + end do + end do + end do + end subroutine get_troplev + !======================================================================= + subroutine zero_inc_strat(grid, k, troplev) + ! adjust increments based off of location of tropopause and some scaling factor + use gridmod, only: lat1, lon1 + use kinds, only: i_kind, r_kind + use control_vectors, only: incvars_efold + implicit none + real(r_kind),dimension(lat1,lon1), intent(inout) :: grid + integer(i_kind),intent(in ) :: k + integer(i_kind),dimension(lat1,lon1), intent(in ) :: troplev + real(r_kind) :: scalefac + integer(i_kind) :: i,j + + do j=1,lat1 + do i=1,lon1 + ! do nothing if troplev is below or equal to k, if above, scale it + if (troplev(j,i) < k) then + scalefac = exp(-(real(k-troplev(j,i)))/incvars_efold) + grid(j,i) = grid(j,i) * scalefac + end if + end do + end do + + + end subroutine zero_inc_strat + + !======================================================================= + + !! Is this variable in incvars_to_zero? + logical function should_zero_increments_for(check_var) + use control_vectors, only : nvars, incvars_to_zero + implicit none + character(len=*), intent(in) :: check_var !! Variable to search for + + ! Local variables + + character(len=12) :: varname ! temporary string for storing variable names + integer :: i ! incvars_to_zero loop index + + should_zero_increments_for=.false. + + zeros_loop: do i=1,nvars + 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 + + !! is this variable in incvars_zero_strat? + logical function zero_increment_strat(check_var) + use control_vectors, only: nvars, incvars_zero_strat + implicit none + character(len=*), intent(in) :: check_var !! Variable to search for + + ! Local variables + + character(len=12) :: varname ! temporary string for storing variable names + integer :: i ! incvars_zero_strat loop index + + zero_increment_strat=.false. + + zeros_loop: do i=1,nvars + varname = incvars_zero_strat(i) + if ( trim(varname) == check_var ) then + zero_increment_strat=.true. + return + endif + end do zeros_loop + end function zero_increment_strat + + + + subroutine nccheck_incr(status) + use netcdf, only: nf90_noerr,nf90_strerror + implicit none + integer, intent (in ) :: status + if (status /= nf90_noerr) then + print *, "fv3_increment netCDF error ", trim(nf90_strerror(status)) + call stop2(999) + end if + end subroutine nccheck_incr + +end module write_incr diff --git a/src/ncdiag/serial/CMakeLists.txt b/src/ncdiag/serial/CMakeLists.txt index fa8a421032..6f6de2348e 100644 --- a/src/ncdiag/serial/CMakeLists.txt +++ b/src/ncdiag/serial/CMakeLists.txt @@ -22,7 +22,7 @@ if(BUILD_NCDIAG) 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} ) + target_link_libraries(nc_diag_cat_serial.x ncdiag_serial ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${ZLIB_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) endif(BUILD_NCDIAG_SERIAL) endif( NOT USE_BASELIBS ) endif(BUILD_NCDIAG) diff --git a/ush/build_all_cmake.sh b/ush/build_all_cmake.sh index fd42e69111..ceaf91d9c7 100755 --- a/ush/build_all_cmake.sh +++ b/ush/build_all_cmake.sh @@ -40,6 +40,9 @@ elif [[ -d /discover ]] ; then export SPACK_ROOT=/discover/nobackup/mapotts1/spack export PATH=$PATH:$SPACK_ROOT/bin . $SPACK_ROOT/share/spack/setup-env.sh +elif [[ -d /work ]]; then + . $MODULESHOME/init/sh + target=orion else echo "unknown target = $target" exit 9 @@ -63,7 +66,7 @@ if [ $target = wcoss_d ]; then elif [ $target = wcoss -o $target = gaea ]; then module purge module load $dir_modules/modulefile.ProdGSI.$target -elif [ $target = hera -o $target = cheyenne ]; then +elif [ $target = hera -o $target = cheyenne -o $target = orion ]; then module purge source $dir_modules/modulefile.ProdGSI.$target elif [ $target = wcoss_c ]; then @@ -77,7 +80,7 @@ else 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 .. + cmake -DBUILD_UTIL=ON -DBUILD_NCDIAG_SERIAL=ON -DCMAKE_BUILD_TYPE=$build_type -DBUILD_CORELIBS=OFF .. else cmake .. fi diff --git a/ush/calcanl_gfs.py b/ush/calcanl_gfs.py new file mode 100755 index 0000000000..2dac8928ed --- /dev/null +++ b/ush/calcanl_gfs.py @@ -0,0 +1,378 @@ +#!/usr/bin/env python +# calcanl_gfs.py +# cory.r.martin@noaa.gov +# 2019-10-11 +# script to run executables to produce netCDF analysis +# on GFS gaussian grid for downstream users +import os +import shutil +import subprocess +import sys +import gsi_utils +from collections import OrderedDict +import datetime + +# function to calculate analysis from a given increment file and background +def calcanl_gfs(DoIAU, l4DEnsVar, Write4Danl, ComOut, APrefix, ASuffix, + FixDir, atmges_ens_mean, RunDir, NThreads, NEMSGet, IAUHrs, + ExecCMD, ExecCMDMPI, ExecAnl, ExecChgresGes, ExecChgresInc, Cdump): + print('calcanl_gfs beginning at: ',datetime.datetime.utcnow()) + + IAUHH = IAUHrs + if Cdump == "gfs": + IAUHH = list(map(int,'6')) + else: + IAUHH = IAUHrs + + ######## copy and link files + if DoIAU and l4DEnsVar and Write4Danl: + for fh in IAUHH: + if fh == 6: + # for full res analysis + CalcAnlDir = RunDir+'/calcanl_'+format(fh, '02') + if not os.path.exists(CalcAnlDir): + os.makedirs(CalcAnlDir) + shutil.copy(ExecAnl, CalcAnlDir+'/calc_anl.x') + gsi_utils.link_file(RunDir+'/siginc.nc', CalcAnlDir+'/siginc.nc.06') + gsi_utils.link_file(RunDir+'/sigf06', CalcAnlDir+'/ges.06') + gsi_utils.link_file(RunDir+'/siganl', CalcAnlDir+'/anl.06') + shutil.copy(ExecChgresInc, CalcAnlDir+'/chgres_inc.x') + # for ensemble res analysis + CalcAnlDir = RunDir+'/calcanl_ensres_'+format(fh, '02') + if not os.path.exists(CalcAnlDir): + os.makedirs(CalcAnlDir) + shutil.copy(ExecAnl, CalcAnlDir+'/calc_anl.x') + gsi_utils.link_file(RunDir+'/siginc.nc', CalcAnlDir+'/siginc.nc.06') + gsi_utils.link_file(ComOut+'/'+APrefix+'atmanl.ensres'+ASuffix, CalcAnlDir+'/anl.ensres.06') + gsi_utils.link_file(RunDir+'/sigf06', CalcAnlDir+'/ges.06') + shutil.copy(ExecChgresGes, CalcAnlDir+'/chgres_ges.x') + + else: + if os.path.isfile('sigi'+format(fh, '02')+'.nc'): + # for full res analysis + CalcAnlDir = RunDir+'/calcanl_'+format(fh, '02') + CalcAnlDir6 = RunDir+'/calcanl_'+format(6, '02') + if not os.path.exists(CalcAnlDir): + os.makedirs(CalcAnlDir) + if not os.path.exists(CalcAnlDir6): + os.makedirs(CalcAnlDir6) + gsi_utils.link_file(ComOut+'/'+APrefix+'atma'+format(fh, '03')+ASuffix, CalcAnlDir6+'/anl.'+format(fh, '02')) + gsi_utils.link_file(RunDir+'/siga'+format(fh, '02'), CalcAnlDir6+'/anl.'+format(fh, '02')) + gsi_utils.link_file(RunDir+'/sigi'+format(fh, '02')+'.nc', CalcAnlDir+'/siginc.nc.'+format(fh, '02')) + gsi_utils.link_file(CalcAnlDir6+'/inc.fullres.'+format(fh, '02'),CalcAnlDir+'/inc.fullres.'+format(fh, '02')) + gsi_utils.link_file(RunDir+'/sigf'+format(fh, '02'), CalcAnlDir6+'/ges.'+format(fh, '02')) + shutil.copy(ExecChgresInc, CalcAnlDir+'/chgres_inc.x') + # for ensemble res analysis + CalcAnlDir = RunDir+'/calcanl_ensres_'+format(fh, '02') + CalcAnlDir6 = RunDir+'/calcanl_ensres_'+format(6, '02') + if not os.path.exists(CalcAnlDir): + os.makedirs(CalcAnlDir) + if not os.path.exists(CalcAnlDir6): + os.makedirs(CalcAnlDir6) + gsi_utils.link_file(ComOut+'/'+APrefix+'atma'+format(fh, '03')+'.ensres'+ASuffix, CalcAnlDir6+'/anl.ensres.'+format(fh, '02')) + gsi_utils.link_file(RunDir+'/sigi'+format(fh, '02')+'.nc', CalcAnlDir6+'/siginc.nc.'+format(fh, '02')) + gsi_utils.link_file(RunDir+'/sigf'+format(fh, '02'), CalcAnlDir+'/ges.'+format(fh, '02')) + gsi_utils.link_file(CalcAnlDir6+'/ges.ensres.'+format(fh, '02'),CalcAnlDir+'/ges.ensres.'+format(fh, '02')) + shutil.copy(ExecChgresGes, CalcAnlDir+'/chgres_ges.x') + + + else: + # for full res analysis + CalcAnlDir = RunDir+'/calcanl_'+format(6, '02') + if not os.path.exists(CalcAnlDir): + os.makedirs(CalcAnlDir) + shutil.copy(ExecAnl, CalcAnlDir+'/calc_anl.x') + gsi_utils.link_file(RunDir+'/siginc.nc', CalcAnlDir+'/siginc.nc.06') + gsi_utils.link_file(RunDir+'/sigf06', CalcAnlDir+'/ges.06') + gsi_utils.link_file(RunDir+'/siganl', CalcAnlDir+'/anl.06') + shutil.copy(ExecChgresInc, CalcAnlDir+'/chgres_inc.x') + # for ensemble res analysis + CalcAnlDir = RunDir+'/calcanl_ensres_'+format(6, '02') + if not os.path.exists(CalcAnlDir): + os.makedirs(CalcAnlDir) + shutil.copy(ExecAnl, CalcAnlDir+'/calc_anl.x') + gsi_utils.link_file(RunDir+'/siginc.nc', CalcAnlDir+'/siginc.nc.06') + gsi_utils.link_file(ComOut+'/'+APrefix+'atmanl.ensres'+ASuffix, CalcAnlDir+'/anl.ensres.06') + gsi_utils.link_file(RunDir+'/sigf06', CalcAnlDir+'/ges.06') + shutil.copy(ExecChgresGes, CalcAnlDir+'/chgres_ges.x') + + # determine if the analysis is to be written in netCDF or NEMSIO + if ASuffix == ".nc": + nemsanl = ".false." + else: + nemsanl = ".true." + + ######## get dimension information from background and increment files + AnlDims = gsi_utils.get_ncdims('siginc.nc') + if ASuffix == ".nc": + GesDims = gsi_utils.get_ncdims('sigf06') + else: + GesDims = gsi_utils.get_nemsdims('sigf06',NEMSGet) + + levs = AnlDims['lev'] + LonA = AnlDims['lon'] + LatA = AnlDims['lat'] + LonB = GesDims['grid_xt'] + LatB = GesDims['grid_yt'] + + # vertical coordinate info + levs2 = levs + 1 + siglevel = FixDir+'/global_hyblev.l'+str(levs2)+'.txt' + + ####### determine how many forecast hours to process + nFH=0 + for fh in IAUHH: + # first check to see if increment file exists + CalcAnlDir = RunDir+'/calcanl_'+format(fh, '02') + if (os.path.isfile(CalcAnlDir+'/siginc.nc.'+format(fh, '02'))): + print('will process increment file: '+CalcAnlDir+'/siginc.nc.'+format(fh, '02')) + nFH+=1 + else: + print('Increment file: '+CalcAnlDir+'/siginc.nc.'+format(fh, '02')+' does not exist. Skipping.') + + sys.stdout.flush() + ######## need to gather information about runtime environment + ExecCMD = ExecCMD.replace("$ncmd","1") + os.environ['OMP_NUM_THREADS'] = str(NThreads) + os.environ['ncmd'] = str(nFH) + ExecCMDMPI1 = ExecCMDMPI.replace("$ncmd",str(1)) + ExecCMDMPI = ExecCMDMPI.replace("$ncmd",str(nFH)) + ExecCMDLevs = ExecCMDMPI.replace("$ncmd",str(levs)) + ExecCMDMPI10 = ExecCMDMPI.replace("$ncmd",str(10)) + + # are we using mpirun with lsf, srun, or aprun with Cray? + launcher = ExecCMDMPI.split(' ')[0] + if launcher == 'mpirun': + hostfile = os.getenv('LSB_DJOB_HOSTFILE','') + with open(hostfile) as f: + hosts_tmp = f.readlines() + hosts_tmp = [x.strip() for x in hosts_tmp] + hosts = [] + [hosts.append(x) for x in hosts_tmp if x not in hosts] + nhosts = len(hosts) + ExecCMDMPI_host = 'mpirun -np '+str(nFH)+' --hostfile hosts' + tasks = int(os.getenv('LSB_DJOB_NUMPROC',1)) + if levs > tasks: + ExecCMDMPILevs_host = 'mpirun -np '+str(tasks)+' --hostfile hosts' + ExecCMDMPILevs_nohost = 'mpirun -np '+str(tasks) + else: + ExecCMDMPILevs_host = 'mpirun -np '+str(levs)+' --hostfile hosts' + ExecCMDMPILevs_nohost = 'mpirun -np '+str(levs) + ExecCMDMPI1_host = 'mpirun -np 1 --hostfile hosts' + ExecCMDMPI10_host = 'mpirun -np 10 --hostfile hosts' + elif launcher == 'srun': + nodes = os.getenv('SLURM_JOB_NODELIST','') + hosts_tmp = subprocess.check_output('scontrol show hostnames '+nodes, shell=True) + if (sys.version_info > (3, 0)): + hosts_tmp = hosts_tmp.decode('utf-8') + hosts_tmp = str(hosts_tmp).splitlines() + hosts_tmp = [x.strip() for x in hosts_tmp] + else: + hosts_tmp = hosts_tmp.strip() + hosts_tmp = str(hosts_tmp).splitlines() + hosts_tmp = [x.strip() for x in hosts_tmp] + hosts = [] + [hosts.append(x) for x in hosts_tmp if x not in hosts] + nhosts = len(hosts) + ExecCMDMPI_host = 'srun -n '+str(nFH)+' --verbose --export=ALL -c 1 --distribution=arbitrary --cpu-bind=cores' + # need to account for when fewer than LEVS tasks are available + tasks = int(os.getenv('SLURM_NPROCS',1)) + if levs > tasks: + ExecCMDMPILevs_host = 'srun -n '+str(tasks)+' --verbose --export=ALL -c 1 --distribution=arbitrary --cpu-bind=cores' + ExecCMDMPILevs_nohost = 'srun -n '+str(tasks)+' --verbose --export=ALL' + else: + ExecCMDMPILevs_host = 'srun -n '+str(levs)+' --verbose --export=ALL -c 1 --distribution=arbitrary --cpu-bind=cores' + ExecCMDMPILevs_nohost = 'srun -n '+str(levs)+' --verbose --export=ALL' + ExecCMDMPI1_host = 'srun -n 1 --verbose --export=ALL -c 1 --distribution=arbitrary --cpu-bind=cores' + ExecCMDMPI10_host = 'srun -n 10 --verbose --export=ALL -c 1 --distribution=arbitrary --cpu-bind=cores' + elif launcher == 'aprun': + hostfile = os.getenv('LSB_DJOB_HOSTFILE','') + with open(hostfile) as f: + hosts_tmp = f.readlines() + hosts_tmp = [x.strip() for x in hosts_tmp] + hosts = [] + [hosts.append(x) for x in hosts_tmp if x not in hosts] + nhosts = len(hosts) + ExecCMDMPI_host = 'aprun -l hosts -d '+str(NThreads)+' -n '+str(nFH) + ExecCMDMPILevs_host = 'aprun -l hosts -d '+str(NThreads)+' -n '+str(levs) + ExecCMDMPILevs_nohost = 'aprun -d '+str(NThreads)+' -n '+str(levs) + ExecCMDMPI1_host = 'aprun -l hosts -d '+str(NThreads)+' -n 1' + ExecCMDMPI10_host = 'aprun -l hosts -d '+str(NThreads)+' -n 10' + else: + print('unknown MPI launcher. Failure.') + sys.exit(1) + + ####### generate the full resolution analysis + interp_jobs = [] + ihost = 0 + ### interpolate increment to full background resolution + for fh in IAUHH: + # first check to see if increment file exists + CalcAnlDir = RunDir+'/calcanl_'+format(fh, '02') + if (os.path.isfile(CalcAnlDir+'/siginc.nc.'+format(fh, '02'))): + # set up the namelist + namelist = OrderedDict() + namelist["setup"] = {"lon_out": LonB, + "lat_out": LatB, + "lev": levs, + "infile": "'siginc.nc."+format(fh, '02')+"'", + "outfile": "'inc.fullres."+format(fh, '02')+"'", + } + gsi_utils.write_nml(namelist, CalcAnlDir+'/fort.43') + + if ihost >= nhosts: + ihost = 0 + with open(CalcAnlDir+'/hosts', 'w') as hostfile: + hostfile.write(hosts[ihost]+'\n') + if launcher == 'srun': # need to write host per task not per node for slurm + for a in range(0,9): # need 9 more of the same host for the 10 tasks for chgres_inc + hostfile.write(hosts[ihost]+'\n') + if launcher == 'srun': + os.environ['SLURM_HOSTFILE'] = CalcAnlDir+'/hosts' + print('interp_inc', fh, namelist) + job = subprocess.Popen(ExecCMDMPI10_host+' '+CalcAnlDir+'/chgres_inc.x', shell=True, cwd=CalcAnlDir) + interp_jobs.append(job) + print(ExecCMDMPI10_host+' '+CalcAnlDir+'/chgres_inc.x submitted on '+hosts[ihost]) + ihost+=1 + + sys.stdout.flush() + exit_codes = [p.wait() for p in interp_jobs] + for ec in exit_codes: + if ec != 0: + print('Error with chgres_inc.x, exit code='+str(ec)) + print(locals()) + sys.exit(ec) + + #### generate analysis from interpolated increment + CalcAnlDir6 = RunDir+'/calcanl_'+format(6, '02') + # set up the namelist + namelist = OrderedDict() + namelist["setup"] = {"datapath": "'./'", + "analysis_filename": "'anl'", + "firstguess_filename": "'ges'", + "increment_filename": "'inc.fullres'", + "fhr": 6, + } + + gsi_utils.write_nml(namelist, CalcAnlDir6+'/calc_analysis.nml') + + # run the executable + if ihost >= nhosts-1: + ihost = 0 + if launcher == 'srun': + del os.environ['SLURM_HOSTFILE'] + print('fullres_calc_anl', namelist) + fullres_anl_job = subprocess.Popen(ExecCMDMPILevs_nohost+' '+CalcAnlDir6+'/calc_anl.x', shell=True, cwd=CalcAnlDir6) + print(ExecCMDMPILevs_nohost+' '+CalcAnlDir6+'/calc_anl.x submitted') + + sys.stdout.flush() + exit_fullres = fullres_anl_job.wait() + sys.stdout.flush() + if exit_fullres != 0: + print('Error with calc_analysis.x for deterministic resolution, exit code='+str(exit_fullres)) + print(locals()) + sys.exit(exit_fullres) + + + ######## run chgres to get background on ensemble resolution + if Cdump == "gdas": + chgres_jobs = [] + for fh in IAUHH: + # first check to see if guess file exists + CalcAnlDir = RunDir+'/calcanl_ensres_'+format(fh, '02') + if (os.path.isfile(CalcAnlDir+'/ges.'+format(fh, '02'))): + # set up the namelist + namelist = OrderedDict() + namelist["chgres_setup"] = {"i_output": str(LonA), + "j_output": str(LatA), + "input_file": "'ges."+format(fh, '02')+"'", + "output_file": "'ges.ensres."+format(fh, '02')+"'", + "terrain_file": "'"+atmges_ens_mean+"'", + "vcoord_file": "'"+siglevel+"'", + } + + gsi_utils.write_nml(namelist, CalcAnlDir+'/chgres_nc_gauss.nml') + + # run the executable + if ihost >= nhosts-1: + ihost = 0 + with open(CalcAnlDir+'/hosts', 'w') as hostfile: + hostfile.write(hosts[ihost]+'\n') + if launcher == 'srun': + os.environ['SLURM_HOSTFILE'] = CalcAnlDir+'/hosts' + print('chgres_nc_gauss', fh, namelist) + job = subprocess.Popen(ExecCMDMPI1_host+' '+CalcAnlDir+'/chgres_ges.x', shell=True, cwd=CalcAnlDir) + chgres_jobs.append(job) + print(ExecCMDMPI1_host+' '+CalcAnlDir+'/chgres_ges.x submitted on '+hosts[ihost]) + ihost+=1 + + sys.stdout.flush() + exit_codes = [p.wait() for p in chgres_jobs] + for ec in exit_codes: + if ec != 0: + print('Error with chgres_ges.x, exit code='+str(ec)) + print(locals()) + sys.exit(ec) + + sys.stdout.flush() + ######## generate ensres analysis from interpolated background + if launcher == 'srun': + del os.environ['SLURM_HOSTFILE'] + for fh in IAUHH: + CalcAnlDir6 = RunDir+'/calcanl_ensres_'+format(6, '02') + # set up the namelist + namelist = OrderedDict() + namelist["setup"] = {"datapath": "'./'", + "analysis_filename": "'anl.ensres'", + "firstguess_filename": "'ges.ensres'", + "increment_filename": "'siginc.nc'", + "fhr": fh, + } + + + gsi_utils.write_nml(namelist, CalcAnlDir6+'/calc_analysis.nml') + + # run the executable + if ihost > nhosts-1: + ihost = 0 + print('ensres_calc_anl', namelist) + ensres_anl_job = subprocess.Popen(ExecCMDMPILevs_nohost+' '+CalcAnlDir6+'/calc_anl.x', shell=True, cwd=CalcAnlDir6) + print(ExecCMDMPILevs_nohost+' '+CalcAnlDir6+'/calc_anl.x submitted') + + sys.stdout.flush() + ####### check on analysis steps + exit_ensres = ensres_anl_job.wait() + if exit_ensres != 0: + print('Error with calc_analysis.x for ensemble resolution, exit code='+str(exit_ensres)) + print(locals()) + sys.exit(exit_ensres) + + print('calcanl_gfs successfully completed at: ',datetime.datetime.utcnow()) + print(locals()) + +# run the function if this script is called from the command line +if __name__ == '__main__': + DoIAU = gsi_utils.isTrue(os.getenv('DOIAU', 'NO')) + l4DEnsVar = gsi_utils.isTrue(os.getenv('l4densvar', 'NO')) + Write4Danl = gsi_utils.isTrue(os.getenv('lwrite4danl', 'NO')) + ComOut = os.getenv('COMOUT', './') + APrefix = os.getenv('APREFIX', '') + ASuffix= os.getenv('ASUFFIX', '') + NThreads = os.getenv('NTHREADS_CHGRES', 1) + FixDir = os.getenv('FIXgsm', './') + atmges_ens_mean = os.getenv('ATMGES_ENSMEAN', './atmges_ensmean') + RunDir = os.getenv('DATA', './') + ExecCMD = os.getenv('APRUN_CALCANL', '') + ExecCMDMPI = os.getenv('APRUN_CALCINC', '') + ExecAnl = os.getenv('CALCANLEXEC', './calc_analysis.x') + ExecChgresGes = os.getenv('CHGRESNCEXEC', './chgres_nc_gauss.exe') + ExecChgresInc = os.getenv('CHGRESINCEXEC', './chgres_increment.exe') + NEMSGet = os.getenv('NEMSIOGET','nemsio_get') + IAUHrs = list(map(int,os.getenv('IAUFHRS','6').split(','))) + Cdump = os.getenv('CDUMP', 'gdas') + + print(locals()) + calcanl_gfs(DoIAU, l4DEnsVar, Write4Danl, ComOut, APrefix, ASuffix, + FixDir, atmges_ens_mean, RunDir, NThreads, NEMSGet, IAUHrs, + ExecCMD, ExecCMDMPI, ExecAnl, ExecChgresGes, ExecChgresInc, + Cdump) diff --git a/ush/calcinc_gfs.py b/ush/calcinc_gfs.py new file mode 100755 index 0000000000..0306d9f39f --- /dev/null +++ b/ush/calcinc_gfs.py @@ -0,0 +1,90 @@ +#!/usr/bin/env python +# calcinc_gfs.py +# cory.r.martin@noaa.gov +# 2019-10-10 +# script to run calc_increment_ens.x to produce +# increment from background and analysis file difference +import os +import shutil +import subprocess +import sys +import gsi_utils +from collections import OrderedDict + +# main function +def calcinc_gfs(DoIAU, l4DEnsVar, Write4Danl, ComOut, APrefix, ASuffix, IAUHrs, + NThreads, IMP_Physics, Inc2Zero, RunDir, Exec, ExecCMD): + # run the calc_increment_ens executable + + # copy and link files + if DoIAU and l4DEnsVar and Write4Danl: + nFH=0 + for fh in IAUHrs: + nFH+=1 + if fh == 6: + gsi_utils.link_file('sigf06', 'atmges_mem'+format(nFH, '03')) + gsi_utils.link_file('siganl', 'atmanl_mem'+format(nFH, '03')) + gsi_utils.link_file(ComOut+'/'+APrefix+'atminc.nc', 'atminc_mem'+format(nFH, '03')) + else: + gsi_utils.link_file('sigf'+format(fh, '02'), 'atmges_mem'+format(nFH, '03')) + gsi_utils.link_file('siga'+format(fh, '02'), 'atmanl_mem'+format(nFH, '03')) + gsi_utils.link_file(ComOut+'/'+APrefix+'atmi'+format(fh, '03')+'.nc', 'atminc_mem'+format(nFH, '03')) + else: + nFH=1 + gsi_utils.link_file('sigf06', 'atmges_mem001') + gsi_utils.link_file('siganl', 'atmanl_mem001') + gsi_utils.link_file(ComOut+'/'+APrefix+'atminc', 'atminc_mem001') + os.environ['OMP_NUM_THREADS'] = str(NThreads) + os.environ['ncmd'] = str(nFH) + shutil.copy(Exec,RunDir+'/calc_inc.x') + ExecCMD = ExecCMD.replace("$ncmd",str(nFH)) + + # set up the namelist + namelist = OrderedDict() + namelist["setup"] = {"datapath": "'./'", + "analysis_filename": "'atmanl'", + "firstguess_filename": "'atmges'", + "increment_filename": "'atminc'", + "debug": ".false.", + "nens": str(nFH), + "imp_physics": str(IMP_Physics)} + + namelist["zeroinc"] = {"incvars_to_zero": Inc2Zero} + + gsi_utils.write_nml(namelist, RunDir+'/calc_increment.nml') + + # run the executable + try: + err = subprocess.check_call(ExecCMD+' '+RunDir+'/calc_inc.x', shell=True) + print(locals()) + except subprocess.CalledProcessError as e: + print('Error with calc_inc.x, exit code='+str(e.returncode)) + print(locals()) + sys.exit(e.returncode) + +# run the function if this script is called from the command line +if __name__ == '__main__': + DoIAU = gsi_utils.isTrue(os.getenv('DOIAU', 'NO')) + l4DEnsVar = gsi_utils.isTrue(os.getenv('l4densvar', 'NO')) + Write4Danl = gsi_utils.isTrue(os.getenv('lwrite4danl', 'NO')) + ComOut = os.getenv('COMOUT', './') + APrefix = os.getenv('APREFIX', '') + ASuffix= os.getenv('ASUFFIX', '') + NThreads = os.getenv('NTHREADS_CALCINC', 1) + IMP_Physics = os.getenv('imp_physics', 11) + RunDir = os.getenv('DATA', './') + ExecNC = os.getenv('CALCINCNCEXEC', './calc_increment_ens_ncio.x') + ExecNEMS = os.getenv('CALCINCEXEC', './calc_increment_ens.x') + Inc2Zero = os.getenv('INCREMENTS_TO_ZERO', '"NONE"') + ExecCMD = os.getenv('APRUN_CALCINC', '') + IAUHrs = list(map(int,os.getenv('IAUFHRS','6').split(','))) + + # determine if the analysis is in netCDF or NEMSIO + if ASuffix == ".nc": + Exec = ExecNC + else: + Exec = ExecNEMS + + print(locals()) + calcinc_gfs(DoIAU, l4DEnsVar, Write4Danl, ComOut, APrefix, ASuffix, IAUHrs, + NThreads, IMP_Physics, Inc2Zero, RunDir, Exec, ExecCMD) diff --git a/ush/getgfsnctime b/ush/getgfsnctime new file mode 100755 index 0000000000..d493339292 --- /dev/null +++ b/ush/getgfsnctime @@ -0,0 +1,34 @@ +#!/usr/bin/env python +# getgfsnctime +# cory.r.martin@noaa.gov +# 2019-10-17 +# script to return initial and valid time +# for specified netCDF file +import argparse +import gsi_utils +import datetime + +if __name__ == '__main__': + parser = argparse.ArgumentParser( + description='Get initial/valid time information from a FV3GFS netCDF file') + parser.add_argument('ncfile', help='path to input netCDF file', + type=str) + parser.add_argument('-i','--init', action='store_true', default=False, + help='option to print out initialized time YYYYMMDDHHMM') + parser.add_argument('-v','--valid', action='store_true', default=False, + help='option to print out valid time YYYYMMDDHHMM') + parser.add_argument('-f','--fhour', action='store_true', default=False, + help='option to print out forecast hour') + args = parser.parse_args() + inittime, validtime, nfhour = gsi_utils.get_timeinfo(args.ncfile) + if args.init: + print(inittime.strftime("%Y%m%d%H%M")) + elif args.valid: + print(validtime.strftime("%Y%m%d%H%M")) + elif args.fhour: + print(nfhour) + else: + print(args.ncfile) + print('Initial time: '+inittime.strftime("%Y-%m-%d %H:%M")) + print('Valid time: '+validtime.strftime("%Y-%m-%d %H:%M")) + print('Forecast hour: '+str(nfhour)) diff --git a/ush/getncdimlen b/ush/getncdimlen new file mode 100755 index 0000000000..5d230f6cc3 --- /dev/null +++ b/ush/getncdimlen @@ -0,0 +1,17 @@ +#!/usr/bin/env python +# getncdimlen +# cory.r.martin@noaa.gov +# 2019-10-17 +# script to return length of requested dimension +# for specified netCDF file +import argparse +import gsi_utils + +if __name__ == '__main__': + parser = argparse.ArgumentParser( + description='Get length of dimension specified from a FV3GFS netCDF file') + parser.add_argument('ncfile', help='path to input netCDF file', type=str) + parser.add_argument('dimname', help='name of dimension (ex: grid_xt)', type=str) + args = parser.parse_args() + FileDims = gsi_utils.get_ncdims(args.ncfile) + print(FileDims[args.dimname]) diff --git a/ush/gsi_utils.py b/ush/gsi_utils.py new file mode 100644 index 0000000000..4916f1ed5c --- /dev/null +++ b/ush/gsi_utils.py @@ -0,0 +1,123 @@ +### gsi_utils.py +### a collection of functions, classes, etc. +### used for the GSI global analysis + +def isTrue(str_in): + """ isTrue(str_in) + - function to translate shell variables to python logical variables + + input: str_in - string (should be like 'YES', 'TRUE', etc.) + returns: status (logical True or False) + + """ + str_in = str_in.upper() + if str_in in ['YES','.TRUE.']: + status = True + else: + status = False + return status + +def link_file(from_file, to_file): + """ link_file(from_file, to_file) + - function to check if a path exists, and if not, make a symlink + input: from_file - string path + to_file - string path + """ + import os + if not os.path.exists(to_file): + if not os.path.islink(to_file): + os.symlink(from_file, to_file) + +def write_nml(nml_dict, nml_file): + """ write_nml(nml_dict, nml_file) + - function to write out namelist dictionary nml_dict to file nml_file + input: nml_dict - dictionary of dictionaries + first dictionary is &nml, second is nmlvar='value' + NOTE: this shoudl be an OrderedDict or else it might fail + nml_file - string path to write namelist file to + """ + nfile = open(nml_file, 'w') + + for nml, nmlvars in nml_dict.items(): + nfile.write('&'+nml+'\n') + for var, val in nmlvars.items(): + nfile.write(' '+str(var)+' = '+str(val)+'\n') + nfile.write('/\n\n') + nfile.close() + + +def get_ncdims(ncfile): + """ get_ncdims(ncfile) + - function to return dictionary of netCDF file dimensions and their lengths + input: ncfile - string to path to netCDF file + output: ncdims - dictionary where key is the name of a dimension and the + value is the length of that dimension + + ex: ncdims['pfull'] = 127 + """ + try: + import netCDF4 as nc + except ImportError: + print("Python Error!") + print("netCDF4 Python module not available. Do you have the proper Python available in your environment?") + print("Hera: module use -a /contrib/modulefiles && module load anaconda/2.3.0") + print("Dell: module load python/3.6.3") + print(" ") + ncf = nc.Dataset(ncfile) + ncdims = {} + for d in ncf.dimensions.keys(): + ncdims[d] = int(len(ncf.dimensions[d])) + ncf.close() + + return ncdims + +def get_nemsdims(nemsfile,nemsexe): + """ get_nemsdims(nemsfile,nemsexe) + - function to return dictionary of NEMSIO file dimensions for use + input: nemsfile - string to path nemsio file + nemsexe - string to path nemsio_get executable + output: nemsdims - dictionary where key is the name of a dimension and the + value is the length of that dimension + ex: nemsdims['pfull'] = 127 + """ + import subprocess + ncdims = { + 'dimx': 'grid_xt', + 'dimy': 'grid_yt', + 'dimz': 'pfull', + } + nemsdims = {} + for dim in ['dimx','dimy','dimz']: + out = subprocess.Popen([nemsexe,nemsfile,dim],stdout=subprocess.PIPE,stderr=subprocess.STDOUT) + stdout, stderr = out.communicate() + nemsdims[ncdims[dim]] = int(stdout.split(' ')[-1].rstrip()) + return nemsdims + +def get_timeinfo(ncfile): + """ get_timeinfo(ncfile) + - function to return datetime objects of initialized time and valid time + input: ncfile - string to path to netCDF file + returns: inittime, validtime - datetime objects + nfhour - integer forecast hour + """ + try: + import netCDF4 as nc + except ImportError: + print("Python Error!") + print("netCDF4 Python module not available. Do you have the proper Python available in your environment?") + print("Hera: module use -a /contrib/modulefiles && module load anaconda/2.3.0") + print("Dell: module load python/3.6.3") + print(" ") + import datetime as dt + import re + ncf = nc.Dataset(ncfile) + time_units = ncf['time'].units + date_str = time_units.split('since ')[1] + date_str = re.sub("[^0-9]", "", date_str) + initstr = date_str[0:10] + inittime = dt.datetime.strptime(initstr,"%Y%m%d%H") + nfhour = int(ncf['time'][0]) + validtime = inittime + dt.timedelta(hours=nfhour) + ncf.close() + + return inittime, validtime, nfhour diff --git a/util/Analysis_Utilities/plots_py/plot_global_inc.py b/util/Analysis_Utilities/plots_py/plot_global_inc.py new file mode 100755 index 0000000000..fe197602c5 --- /dev/null +++ b/util/Analysis_Utilities/plots_py/plot_global_inc.py @@ -0,0 +1,40 @@ +#!/usr/bin/env python +import argparse +import netCDF4 as nc +import matplotlib +matplotlib.use('agg') +import matplotlib.pyplot as plt +import cartopy.crs as ccrs +import numpy as np + +def plot_2d_inc(inpath, varname, lev, plotpath): + # read in the increment array + ncf = nc.Dataset(inpath) + incvar = ncf.variables[varname][:] + inclev = incvar[lev,...] + # calculate min/max for plotting + minval = np.nanmin(inclev) + maxval = np.nanmax(inclev) + prange = max([minval,maxval], key=abs) + # set up map/figure + ax = plt.axes(projection=ccrs.PlateCarree()) + ax.coastlines(resolution='10m') + # get lat lon values + lat = ncf.variables['lat'][:] + lon = ncf.variables['lon'][:] + lons, lats = np.meshgrid(lon,lat) + plt.pcolormesh(lons, lats, inclev, vmin=-prange, vmax=prange, cmap='bwr') + plt.colorbar(orientation='horizontal',label='minval='+'{:.4f}'.format(minval)+' maxval='+'{:.4f}'.format(maxval)) + plt.title(inpath+'\n'+varname+' Analysis Increment Lev='+str(lev+1)) + plt.savefig(plotpath) + +if __name__ == '__main__': + parser = argparse.ArgumentParser(description='Plot Global GSI Analysis Increments') + parser.add_argument('-i', '--input', help='path to input netCDF increment file (ex: /path/to/siginc.nc', + type=str, required=True) + parser.add_argument('-v', '--var', help='name of variable (ex: T_inc)', type=str, required=True) + parser.add_argument('-l', '--lev', help='model level to plot (ex: 127)', type=int, required=True) + parser.add_argument('-p', '--plot', help='path to output figure (ex: /path/to/plot.png', type=str, required=True) + args = parser.parse_args() + + plot_2d_inc(args.input, args.var, args.lev-1, args.plot) diff --git a/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/CMakeLists.txt b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/CMakeLists.txt new file mode 100644 index 0000000000..bc97cffb28 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/CMakeLists.txt @@ -0,0 +1,14 @@ +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(Util_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/calc_increment_ens_ncio") + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + add_executable(calc_increment_ens_ncio.x ${LOCAL_SRC} ) + set_target_properties( calc_increment_ens_ncio.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + set_target_properties( calc_increment_ens_ncio.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} ${FV3GFS_NCIO_INCS}) + target_link_libraries( calc_increment_ens_ncio.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} ${FV3GFS_NCIO_LIBRARIES}) +endif() diff --git a/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/calc_increment_interface.f90 b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/calc_increment_interface.f90 new file mode 100644 index 0000000000..41c0ac59b0 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.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/calc_increment_ens_ncio.fd/constants.f90 b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/constants.f90 new file mode 100644 index 0000000000..c0a066eec0 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.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/EnKF/gfs/src/calc_increment_ens_ncio.fd/fv3_interface.f90 b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/fv3_interface.f90 new file mode 100644 index 0000000000..2eb31b836e --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/fv3_interface.f90 @@ -0,0 +1,708 @@ +! 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_ncio_interface + use namelist_def + use netcdf + + !----------------------------------------------------------------------- + + 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 = 9 !! number of known variables + + ! Define global variables + + type(ncio_meta) :: meta_ncio !! ncio 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 ', 'liq_wat_inc', 'o3mwr_inc ', & + 'icmr_inc ' /) + + !! The input name from ncio 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 + + !======================================================================= + !======================================================================= + + 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 :: 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 ncio header + call gfs_ncio_initialize(meta_ncio, firstguess_filename) + call gfs_grid_initialize(grid, meta_ncio) + + 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_ncio_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(trim(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 + call fv3_analysis_read_or_calc_dpres(an_grid) + call fv3_analysis_read_or_calc_dpres(fg_grid) + 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=12) :: 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 + + real(r_kind), allocatable :: workgrid(:,:,:) ! for reordering data + integer :: k ! Vertical index loop + + + ! Read the ncio file header + call gfs_ncio_initialize(meta_ncio,filename=grid%filename) + + ! Allocate our local work array + allocate(workgrid(grid%nx,grid%ny,grid%nz)) + + ! Read in the variable, level-by-level: + call gfs_ncio_read(workgrid,varname) + do k = 1, grid%nz + grid%var3d(:,:,k)=workgrid(:,:,k) + if (grid%flip_lats) then + call gfs_ncio_flip_xlat_axis( & + meta_ncio,grid%var3d(:,:,k)) + endif + end do + + ! Close the ncio file + call gfs_ncio_finalize() + + deallocate(workgrid) + + end subroutine fv3_analysis_read_var + + !======================================================================= + + !! Read or calculate 3D pressure + subroutine fv3_analysis_read_or_calc_dpres(grid) + ! Arguments to function + + type(analysis_grid) :: grid !! the analysis or first guess grid + + ! local variables + + real(r_kind), allocatable :: workgrid(:,:,:) ! for reordering data + integer :: k ! Vertical index loop when reading data level-by-level + + ! Read the ncio file header + call gfs_ncio_initialize(meta_ncio,filename=grid%filename) + + allocate(workgrid(meta_ncio%dimx,meta_ncio%dimy,meta_ncio%dimz)) + + ! Calculate or read the mid-level 3D pressure: + call gfs_ncio_read(workgrid,'dpres ') + do k = 1, meta_ncio%dimz + grid%var3d(:,:,k)=workgrid(:,:,k) + ! Flip the pressure in the latitude direction if needed + if (grid%flip_lats) then + call gfs_ncio_flip_xlat_axis( & + meta_ncio, grid%var3d(:,:,k) ) + endif + enddo + + 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 + + ! Read the ncio file header + call gfs_ncio_initialize(meta_ncio,filename=grid%filename) + + ! Allocate memory for work arrays + grid%nx=meta_ncio%dimx + grid%ny=meta_ncio%dimy + grid%nz=meta_ncio%dimz + + ! Determine ordering of latitudes: + if (debug) then + print *,'lats',meta_ncio%lat(1), meta_ncio%lat( & + meta_ncio%dimx*meta_ncio%dimy) + endif + if (meta_ncio%lat(1) > meta_ncio%lat(meta_ncio%dimx*meta_ncio%dimy)) then + grid%flip_lats = .true. + else + grid%flip_lats = .false. + endif + if (debug) print *,'flip_lats',grid%flip_lats + + ! Close this ncio file. + call gfs_ncio_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_ncio_initialize(meta_ncio,filename=analysis_filename) + an_grid%nx = meta_ncio%dimx + an_grid%ny = meta_ncio%dimy + an_grid%nz = meta_ncio%dimz + an_grid%nzp1 = an_grid%nz + 1 + call gfs_ncio_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/EnKF/gfs/src/calc_increment_ens_ncio.fd/gfs_ncio_interface.f90 b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/gfs_ncio_interface.f90 new file mode 100644 index 0000000000..4d3d07236b --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/gfs_ncio_interface.f90 @@ -0,0 +1,359 @@ +! 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_ncio_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use constants + use kinds + + !----------------------------------------------------------------------- + + use namelist_def + use module_fv3gfs_ncio + + !----------------------------------------------------------------------- + + 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 ncio_meta + real, dimension(:,:), allocatable :: vcoord + real, dimension(:), allocatable :: lon + real, dimension(:), allocatable :: lat + real :: rlon_min + real :: rlon_max + real :: rlat_min + real :: rlat_max + integer :: idate(6) + integer :: dimx + integer :: dimy + integer :: dimz + integer :: ntrac + integer :: ncldt + integer :: idvc + integer :: idsl + integer :: idvm + integer :: fhour + end type ncio_meta ! type ncio_meta + + !----------------------------------------------------------------------- + + ! Define global variables + + type(Dataset) :: gfile + + !----------------------------------------------------------------------- + + ! Define interfaces and attributes for module routines + + private + public :: gfs_grid_initialize + public :: gfs_grid_cleanup + public :: gfs_grid + public :: gfs_ncio_initialize + public :: gfs_ncio_finalize + public :: gfs_ncio_read + public :: gfs_ncio_vcoord + public :: gfs_ncio_flip_xlat_axis + public :: ncio_meta + + !----------------------------------------------------------------------- + +contains + + !======================================================================= + + ! gfs_ncio_initialize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_ncio_initialize(meta_ncio,filename) + + ! Define variables passed to routine + + type(ncio_meta) :: meta_ncio + character(len=500), optional, intent(inout) :: filename + type(Dimension) :: ncdim + real, allocatable, dimension(:) :: tmp1d + real, allocatable, dimension(:,:) :: tmp2d + + !===================================================================== + + gfile = open_dataset(trim(adjustl(filename))) + ncdim = get_dim(gfile,'grid_xt'); meta_ncio%dimx = ncdim%len + ncdim = get_dim(gfile,'grid_yt'); meta_ncio%dimy = ncdim%len + ncdim = get_dim(gfile,'pfull'); meta_ncio%dimz = ncdim%len + if (.not. allocated(meta_ncio%lon)) & + allocate(meta_ncio%lon(meta_ncio%dimx*meta_ncio%dimy)) + if (.not. allocated(meta_ncio%lat)) & + allocate(meta_ncio%lat(meta_ncio%dimx*meta_ncio%dimy)) + call read_vardata(gfile,'lon', tmp2d) + meta_ncio%lon = reshape(tmp2d, (/meta_ncio%dimx*meta_ncio%dimy/)) + call read_vardata(gfile,'lat', tmp2d) + meta_ncio%lat = reshape(tmp2d, (/meta_ncio%dimx*meta_ncio%dimy/)) + meta_ncio%idate = get_idate_from_time_units(gfile) + ! hard code these values that are the same for GFS + meta_ncio%idvc=2 + meta_ncio%idsl=1 + meta_ncio%idvm=1 + meta_ncio%ntrac = 8 + meta_ncio%ncldt = 5 + + call read_vardata(gfile,'time',tmp1d) + meta_ncio%fhour = nint(tmp1d(1)) + + end subroutine gfs_ncio_initialize + + !======================================================================= + + ! gfs_ncio_finalize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_ncio_finalize() + + !===================================================================== + + call close_dataset(gfile) + + !===================================================================== + + end subroutine gfs_ncio_finalize + + !======================================================================= + + ! gfs_ncio_vcoord.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_ncio_vcoord(meta_ncio,filename,vcoord) + + ! Define variables passed to routine + + type(Dataset) :: lgfile + type(ncio_meta) :: meta_ncio + character(len=500) :: filename + real(r_kind), dimension(meta_ncio%dimz+1,2) :: vcoord + real, allocatable, dimension(:) :: tmp1d + + !===================================================================== + + ! Define local variables + + lgfile = open_dataset(trim(adjustl(filename))) + call read_attribute(lgfile,'ak',tmp1d) + vcoord(:,1) = tmp1d(:) + call read_attribute(lgfile,'bk',tmp1d) + vcoord(:,2) = tmp1d(:) + call close_dataset(lgfile) + + !===================================================================== + + end subroutine gfs_ncio_vcoord + + !======================================================================= + + ! gfs_ncio_flip_xlat_axis.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_ncio_flip_xlat_axis(meta_ncio,grid) + ! flip latitudes from N to S to S to N + + ! Define variables passed to routine + + type(ncio_meta) :: meta_ncio + real, dimension(meta_ncio%dimx,meta_ncio%dimy) :: grid + + ! Define variables computed within routine + + real, dimension(meta_ncio%dimx,meta_ncio%dimy) :: workgrid + + ! Define counting variables + + integer :: i, j + + !===================================================================== + + ! Define local variables + + workgrid = grid + + ! Loop through local variable + + do j = 1, meta_ncio%dimy + + ! Loop through local variable + + do i = 1, meta_ncio%dimx + + ! Define local variables + + grid(i,meta_ncio%dimy - j + 1) = workgrid(i,j) + + end do ! do i = 1, meta_ncio%dimx + + end do ! do j = 1, meta_ncio%dimy + + !===================================================================== + + end subroutine gfs_ncio_flip_xlat_axis + + !======================================================================= + + ! gfs_ncio_read.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_ncio_read(ncio_data,ncio_varname) + + ! Define variables passed to routine + + character(10) :: ncio_varname + real,allocatable :: ncio_data(:,:,:) + + call read_vardata(gfile,trim(ncio_varname),ncio_data) + + + !===================================================================== + + end subroutine gfs_ncio_read + + + !======================================================================= + + ! gfs_grid_initialize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_grid_initialize(grid,meta_ncio) + + ! Define variables passed to routine + + type(gfs_grid) :: grid + type(ncio_meta) :: meta_ncio + + ! 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_ncio%lon(n) + grid%rlat(i,j) = meta_ncio%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_ncio_interface diff --git a/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/kinds.f90 b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/kinds.f90 new file mode 100644 index 0000000000..b3378bfccf --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.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_ens_ncio.fd/main.f90 b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/main.f90 new file mode 100644 index 0000000000..69a70ab563 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.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/EnKF/gfs/src/calc_increment_ens_ncio.fd/namelist_def.f90 b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/namelist_def.f90 new file mode 100644 index 0000000000..4f20d219e9 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.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=12) :: 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/EnKF/gfs/src/calc_increment_ens_ncio.fd/pmain.f90 b/util/EnKF/gfs/src/calc_increment_ens_ncio.fd/pmain.f90 new file mode 100644 index 0000000000..9ef78eeb36 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ens_ncio.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/EnKF/gfs/src/calc_increment_ncio.fd/CMakeLists.txt b/util/EnKF/gfs/src/calc_increment_ncio.fd/CMakeLists.txt new file mode 100644 index 0000000000..cd3928f602 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ncio.fd/CMakeLists.txt @@ -0,0 +1,11 @@ +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_ncio.x ${LOCAL_SRC} ) + set_target_properties( calc_increment_ncio.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${UTIL_INC} ${NEMSIOINC} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ${FV3GFS_NCIO_INCS}) + target_link_libraries( calc_increment_ncio.x ${CORE_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_LIBRARIES} ${HDF5_LIBRARIES} ${FV3GFS_NCIO_LIBRARIES} ) +endif() diff --git a/util/EnKF/gfs/src/calc_increment_ncio.fd/calc_increment_ncio.f90 b/util/EnKF/gfs/src/calc_increment_ncio.fd/calc_increment_ncio.f90 new file mode 100755 index 0000000000..42d7fc136c --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_ncio.fd/calc_increment_ncio.f90 @@ -0,0 +1,389 @@ +PROGRAM calc_increment_ncio +!$$$ main program documentation block +! +! program: calc_increment_ncio +! +! prgmmr: whitaker org: esrl/psd date: 2019-02-23 +! +! abstract: difference two ncio files, write out increment netcdf increment +! file for ingest into FV3. The data in increment file must be oriented +! from south to north and from top to bottom in the vertical. +! if dpres and delz are not in ncio files, increments are inferred from +! ps and T. +! +! program history log: +! 2019-02-12 Initial version. +! +! usage: +! input files: filename_fg filename_anal (1st two command line args) +! +! output files: filename_inc (3rd command line arg) + +! 4th command line arg is logical for controlling whether microphysics +! increment is computed. +! +! attributes: +! language: f95 +! +! ifort -O3 -xHOST -I${NCIO_INC} -I${NETCDF}/include calc_increment_ncio.f90 +! ${NCIO_LIB} ${W3NCO_LIB4} ${BACIO_LIB4} -L${NETCDF}/lib -lnetcdf -lnetcdff +! +!$$$ + + use module_fv3gfs_ncio, only: open_dataset, create_dataset, read_attribute, & + Dataset, Dimension, close_dataset, & + read_vardata, write_attribute, write_vardata, & + has_var, has_attr, get_dim + use netcdf + + implicit none + + character*500 filename_anal,filename_inc,filename_fg + character(len=nf90_max_name) :: ncvarname + integer k,nvar,ndims,nlats,nlons,nlevs,iret,nlons2,nlats2,nlevs2 + real, allocatable, dimension(:) :: lats_tmp, lats, lons, ak, bk, ilevs, levs + real, allocatable, dimension(:,:) :: values_2d_fg,values_2d_anal,values_2d_inc,& + ps_fg, ps_anal + real, allocatable, dimension(:,:,:) :: values_3d_fg,values_3d_anal,values_3d_inc,& + q_fg, q_anal, tmp_fg, tmp_anal, delzb, delza + type(Dataset) :: dset_anal,dset_fg + type(Dimension) :: londim,latdim,levdim + integer, dimension(3) :: dimid_3d + integer, dimension(1) :: dimid_1d + integer varid_lon,varid_lat,varid_lev,varid_ilev,varid_hyai,varid_hybi,& + dimid_lon,dimid_lat,dimid_lev,dimid_ilev,ncfileid,ncstatus + logical :: no_mpinc, no_delzinc, has_dpres, has_delz + character(len=10) :: bufchar + real rd,rv,fv,grav + + rd = 2.8705e+2 + rv = 4.6150e+2 + fv = rv/rd-1. ! used in virtual temperature equation + grav = 9.80665 + + call getarg(1,filename_fg) ! first guess ncio file + call getarg(2,filename_anal) ! analysis ncio file + call getarg(3,filename_inc) ! output increment file + call getarg(4, bufchar) + read(bufchar,'(L)') no_mpinc ! if T, no microphysics increments computed + call getarg(5, bufchar) + read(bufchar,'(L)') no_delzinc ! if T, no delz increments computed + + write(6,*)'CALC_INCREMENT_NCIO:' + write(6,*)'filename_fg=',trim(filename_fg) + write(6,*)'filename_anal=',trim(filename_anal) + write(6,*)'filename_inc=',trim(filename_inc) + write(6,*)'no_mpinc',no_mpinc + write(6,*)'no_delzinc',no_delzinc + + dset_fg = open_dataset(trim(filename_fg),errcode=iret) + if (iret .ne. 0) then + print *,'error opening ',trim(filename_fg) + stop + endif + dset_anal = open_dataset(trim(filename_anal),errcode=iret) + if (iret .ne. 0) then + print *,'error opening ',trim(filename_anal) + stop + endif + + londim = get_dim(dset_fg,'grid_xt'); nlons = londim%len + latdim = get_dim(dset_fg,'grid_yt'); nlats = latdim%len + levdim = get_dim(dset_fg,'pfull'); nlevs = levdim%len + londim = get_dim(dset_anal,'grid_xt'); nlons2 = londim%len + latdim = get_dim(dset_anal,'grid_yt'); nlats2 = latdim%len + levdim = get_dim(dset_anal,'pfull'); nlevs2 = levdim%len + print *,'nlons,nlats,nlevs',nlons,nlats,nlevs + print *,'nlons2,nlats2,nlevs2',nlons2,nlats2,nlevs2 + if ( nlons /= nlons2 .or. nlats /= nlats2 .or. & + nlevs /= nlevs2) then + print *,'expecting nlons,nlats,nlevs =',nlons,nlats,nlevs + print *,'got nlons,nlats,nlevs =',nlons2,nlats2,nlevs2 + stop + endif + + call read_vardata(dset_fg, 'grid_xt', lons) + call read_vardata(dset_fg, 'grid_yt', lats_tmp) + allocate(ak(nlevs+1),bk(nlevs+1),levs(nlevs),ilevs(nlevs+1),lats(nlats)) + call read_attribute(dset_fg, 'ak', ak) + call read_attribute(dset_fg, 'bk', bk) + lats = lats_tmp(nlats:1:-1) + if (lats(1) .gt. lats(nlats)) then + print *,'error: code assumes lats in ncio files are N to S' + stop + endif + deallocate(lats_tmp) + +! create netcdf increment file. + ncstatus = nf90_create(trim(filename_inc), & + cmode=ior(NF90_CLOBBER,NF90_NETCDF4),ncid=ncfileid) + if (ncstatus /= nf90_noerr) then + print *, 'error opening file ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_def_dim(ncfileid,'lon',nlons,dimid_lon) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lon dim ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_def_dim(ncfileid,'lat',nlats,dimid_lat) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lat dim ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_def_dim(ncfileid,'lev',nlevs,dimid_lev) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lev dim ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_def_dim(ncfileid,'ilev',nlevs+1,dimid_ilev) + if (ncstatus /= nf90_noerr) then + print *, 'error creating ilev dim ',trim(nf90_strerror(ncstatus)) + stop + endif + dimid_1d(1) = dimid_lon + ncstatus = nf90_def_var(ncfileid,'lon',nf90_float,dimid_1d, & + & varid_lon) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lon ',trim(nf90_strerror(ncstatus)) + stop + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + endif + ncstatus = nf90_put_att(ncfileid,nf90_global,'comment','global analysis increment from calc_increment_ncio') + if (ncstatus /= nf90_noerr) then + print *, 'error creating global attribute comment',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_enddef(ncfileid) + if (ncstatus /= nf90_noerr) then + print *,'enddef error ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_put_var(ncfileid,varid_lon,lons) + if (ncstatus /= nf90_noerr) then + print *, 'error writing lon ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_put_var(ncfileid,varid_lat,lats) + if (ncstatus /= nf90_noerr) then + print *, 'error writing lat ',trim(nf90_strerror(ncstatus)) + stop + endif + do k=1,nlevs + levs(k)=k + enddo + ncstatus = nf90_put_var(ncfileid,varid_lev,levs) + if (ncstatus /= nf90_noerr) then + print *, 'error writing lev ',trim(nf90_strerror(ncstatus)) + stop + endif + do k=1,nlevs+1 + ilevs(k)=k + enddo + ncstatus = nf90_put_var(ncfileid,varid_ilev,ilevs) + if (ncstatus /= nf90_noerr) then + print *, 'error writing ilev ',trim(nf90_strerror(ncstatus)) + stop + endif + ! note that levels go from top to bottom (opposite to ncio files) + ncstatus = nf90_put_var(ncfileid,varid_hyai,ak) + if (ncstatus /= nf90_noerr) then + print *, 'error writing hyai ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_put_var(ncfileid,varid_hybi,bk) + if (ncstatus /= nf90_noerr) then + print *, 'error writing hybi ',trim(nf90_strerror(ncstatus)) + stop + endif + + dimid_3d(1) = dimid_lon + dimid_3d(2) = dimid_lat + dimid_3d(3) = dimid_lev + + has_dpres = has_var(dset_fg,'dpres') + has_delz = has_var(dset_fg,'delz') + !has_dpres = .false.; has_delz = .false. ! for debugging only + print *,'has_dpres ',has_dpres + print *,'has_delz ',has_delz + + ! ps increment. + allocate(values_2d_inc(nlons,nlats)) + allocate(values_3d_inc(nlons,nlats,nlevs)) + do nvar=1,dset_fg%nvars + ndims = dset_fg%variables(nvar)%ndims + if (trim(dset_fg%variables(nvar)%name) == 'pressfc') then + call read_vardata(dset_fg,trim(dset_fg%variables(nvar)%name),values_2d_fg) + call read_vardata(dset_anal,trim(dset_fg%variables(nvar)%name),values_2d_anal) + ! increment (flip lats) + values_2d_inc(:,nlats:1:-1) = values_2d_anal - values_2d_fg + endif + enddo + + do nvar=1,dset_fg%nvars + ndims = dset_fg%variables(nvar)%ndims + if (ndims == 4) then ! all 3d vars + ncvarname = 'none' + !print *,trim(dset_fg%variables(nvar)%name) + if (trim(dset_fg%variables(nvar)%name) == 'ugrd') then + ncvarname = 'u_inc' + else if (trim(dset_fg%variables(nvar)%name) == 'vgrd') then + ncvarname = 'v_inc' + else if (trim(dset_fg%variables(nvar)%name) == 'tmp') then + ncvarname = 'T_inc' + else if (trim(dset_fg%variables(nvar)%name) == 'dpres' .and. & + has_dpres) then + ncvarname = 'delp_inc' + else if (trim(dset_fg%variables(nvar)%name) == 'spfh') then + ncvarname = 'sphum_inc' + else if (trim(dset_fg%variables(nvar)%name) == 'o3mr') then + ncvarname = 'o3mr_inc' + else if (trim(dset_fg%variables(nvar)%name) == 'delz' .and. & + .not. no_delzinc .and. has_delz) then + ncvarname = 'delz_inc' + else if (trim(dset_fg%variables(nvar)%name) == 'clwmr' .and. & + .not. no_mpinc) then + ncvarname = 'liq_wat_inc' + else if (trim(dset_fg%variables(nvar)%name) == 'icmr' .and. & + .not. no_mpinc) then + ncvarname = 'ice_wat_inc' + endif + if (trim(ncvarname) /= 'none') then + call read_vardata(dset_fg,trim(dset_fg%variables(nvar)%name),values_3d_fg) + call read_vardata(dset_anal,trim(dset_fg%variables(nvar)%name),values_3d_anal) + ! increment (flip lats) + values_3d_inc(:,nlats:1:-1,:) = values_3d_anal - values_3d_fg + call write_ncdata3d(values_3d_inc,ncvarname,nlons,nlats,nlevs,ncfileid,dimid_3d) + endif + endif ! ndims == 4 + enddo ! nvars + ! infer delp increment from ps increment + if (.not. has_dpres) then + print *,'inferring delp_inc from ps inc' + ncvarname = 'delp_inc' + ! ak,bk go from top to bottom, so bk(k+1)-bk(k) > 0 + do k=1,nlevs + values_3d_inc(:,:,k) = values_2d_inc*(bk(k+1)-bk(k)) + enddo + call write_ncdata3d(values_3d_inc,ncvarname,nlons,nlats,nlevs,ncfileid,dimid_3d) + endif + ! infer delz increment from background, analysis ps & Tv + if (.not. has_delz .and. .not. no_delzinc) then + print *,'inferring delz_inc from anal and background ps & Tv' + ncvarname = 'delz_inc' + call read_vardata(dset_fg,'tmp',tmp_fg) + call read_vardata(dset_anal,'tmp',tmp_anal) + call read_vardata(dset_fg,'spfh',q_fg) + call read_vardata(dset_anal,'spfh',q_anal) + call read_vardata(dset_fg,'pressfc',ps_fg) + call read_vardata(dset_anal,'pressfc',ps_anal) + tmp_fg = tmp_fg * ( 1.0 + fv*q_fg ) ! convert T to Tv + tmp_anal = tmp_anal * ( 1.0 + fv*q_anal ) + allocate(delzb(nlons,nlats,nlevs)) + allocate(delza(nlons,nlats,nlevs)) + delzb = (rd/grav)*tmp_fg + delza = (rd/grav)*tmp_anal + do k=1,nlevs + delzb(:,:,k)=delzb(:,:,k)*log((ak(k)+bk(k)*ps_fg)/(ak(k+1)+bk(k+1)*ps_fg)) + delza(:,:,k)=delza(:,:,k)*log((ak(k)+bk(k)*ps_anal)/(ak(k+1)+bk(k+1)*ps_anal)) + !print *,k,minval(delzb(:,:,k)),maxval(delzb(:,:,k)),bk(k),bk(k+1)-bk(k) + enddo + !print *,'min/max anal delz',minval(delza),maxval(delza) + !print *,'min/max fg delz',minval(delzb),maxval(delzb) + values_3d_inc(:,nlats:1:-1,:) = delza - delzb + call write_ncdata3d(values_3d_inc,ncvarname,nlons,nlats,nlevs,ncfileid,dimid_3d) + endif + + ncstatus = nf90_close(ncfileid) + if (ncstatus /= nf90_noerr) then + print *, 'error closing file:',trim(nf90_strerror(ncstatus)) + stop + endif + call close_dataset(dset_fg) + call close_dataset(dset_anal) + +END PROGRAM calc_increment_ncio + +subroutine write_ncdata3d(incdata,ncvarname,& + nlons,nlats,nlevs,ncfileid,dimid_3d) + use netcdf + integer, intent(in) :: nlons,nlats,nlevs,ncfileid,dimid_3d(3) + integer varid,ncstatus + real, intent(in) :: incdata(nlons,nlats,nlevs) + character(len=nf90_max_name), intent(in) :: ncvarname + + ncstatus = nf90_redef(ncfileid) + if (ncstatus /= nf90_noerr) then + print *,'redef error ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_def_var(ncfileid,trim(ncvarname),nf90_float,dimid_3d,varid) + if (ncstatus /= nf90_noerr) then + print *, 'error creating ',trim(ncvarname),' ',trim(nf90_strerror(ncstatus)) + stop + endif + ! turn on compression (level 1) + ncstatus = nf90_def_var_deflate(ncfileid, varid, 1,1,1) + if (ncstatus /= nf90_noerr) then + print *,'nc_def_var_deflate error ',trim(nf90_strerror(ncstatus)) + stop + endif + ncstatus = nf90_enddef(ncfileid) + if (ncstatus /= nf90_noerr) then + print *,'enddef error ',trim(nf90_strerror(ncstatus)) + stop + endif + print *,'writing ',trim(ncvarname),' min/max =',minval(incdata),maxval(incdata) + ncstatus = nf90_put_var(ncfileid,varid,incdata) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop + endif +end subroutine write_ncdata3d diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsfcensmeanp.fd/CMakeLists.txt index 41c01b0266..df033c979a 100644 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/getsfcensmeanp.fd/CMakeLists.txt @@ -5,6 +5,6 @@ if(BUILD_UTIL) 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} ${OpenMP_Fortran_FLAGS}" ) - include_directories( ${SFCIOINC} ${NEMSIOINC} ) - target_link_libraries( getsfcensmeanp.x ${SFCIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) + include_directories( ${NEMSIOINC} ${SFCIOINC} ${NETCDF_INCLUDES} ${FV3GFS_NCIO_INCS}) + target_link_libraries( getsfcensmeanp.x ${BACIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${SFCIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${FV3GFS_NCIO_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/getsfcensmeanp.f90 b/util/EnKF/gfs/src/getsfcensmeanp.fd/getsfcensmeanp.f90 index ad4aefa6d9..8326cf2809 100644 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/getsfcensmeanp.f90 +++ b/util/EnKF/gfs/src/getsfcensmeanp.fd/getsfcensmeanp.f90 @@ -25,18 +25,26 @@ program getsfcensmeanp 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 + use module_fv3gfs_ncio, only: open_dataset, create_dataset, read_attribute, & + Dataset, Dimension, close_dataset, & + read_vardata, write_attribute, write_vardata, & + get_dim implicit none real(4),parameter:: zero=0.0_4 - logical:: nemsio, sfcio + logical:: nemsio, sfcio, ncio + + type(Dataset) :: dset,dseto + type(Dimension) :: londim,latdim + real(4), allocatable, dimension(:,:) :: values_2d, values_2d_avg character*500 filenamein,filenameout,datapath,fileprefix character*3 charnanal integer lunin,lunout,iret,nanals,k integer mype,mype1,npe,orig_group, new_group, new_comm - integer nrec, lonb, latb, n, npts + integer nrec, lonb, latb, n, npts, nvar integer,dimension(7):: idate integer,dimension(:),allocatable:: new_group_members real(8) rnanals @@ -106,28 +114,39 @@ program getsfcensmeanp sfcio=.false. nemsio=.false. + ncio=.false. ! Process input files (one file per task) if (mype1 <= nanals) then - call nemsio_init(iret=iret) - write(charnanal,'(i3.3)') mype1 filenamein = trim(adjustl(datapath))// & trim(adjustl(fileprefix))//'_mem'//charnanal - call sfcio_srohdc(lunin,filenamein,sfcheadi,sfcdatai,iret) - if (iret == 0 ) then - sfcio = .true. + + dset = open_dataset(filenamein,errcode=iret) + if (iret == 0) then + ncio = .true. else - call nemsio_open(gfile,trim(filenamein),'READ',iret=iret) + ncio = .false. + endif + + if (.not. ncio) then + call nemsio_init(iret=iret) + call sfcio_srohdc(lunin,filenamein,sfcheadi,sfcdatai,iret) if (iret == 0 ) then - nemsio = .true. + sfcio = .true. else - write(6,*)'***ERROR*** ',trim(filenamein),' contains unrecognized format. ABORT' + call nemsio_open(gfile,trim(filenamein),'READ',iret=iret) + if (iret == 0 ) then + nemsio = .true. + else + write(6,*)'***ERROR*** ',trim(filenamein),' contains unrecognized format. ABORT' + endif endif endif - if (.not.nemsio .and. .not.sfcio) goto 100 - if (mype==0) write(6,*)'computing mean with nemsio=',nemsio,' sfcio=',sfcio + if (.not. ncio .and. .not.nemsio .and. .not.sfcio) goto 100 + if (mype==0) write(6,*)'computing mean with nemsio=',nemsio,& + ' sfcio=',sfcio,' ncio=',ncio if (sfcio) then @@ -281,8 +300,40 @@ program getsfcensmeanp call nemsio_close(gfileo,iret=iret) write(6,*)'Write ensmemble mean ',trim(filenameout),' iret=',iret endif + elseif (ncio) then + londim = get_dim(dset,'grid_xt'); lonb = londim%len + latdim = get_dim(dset,'grid_yt'); latb = latdim%len + allocate(values_2d_avg(lonb,latb)) + if (mype == 0) then + dseto = create_dataset(filenameout, dset, copy_vardata=.true.) + print *,'opened netcdf file ',trim(filenameout) + endif + do nvar=1,dset%nvars +! Following fields are not averaged +! land = land/sea mask +! vtype = veg type +! sltype = slope type +! sotype = soil type +! orog = orography + if (dset%variables(nvar)%ndims < 3 .or. & + trim(dset%variables(nvar)%name) == 'land' .or. & + trim(dset%variables(nvar)%name) == 'vtype' .or. & + trim(dset%variables(nvar)%name) == 'sltype' .or. & + trim(dset%variables(nvar)%name) == 'sotyp' .or. & + trim(dset%variables(nvar)%name) == 'orog') then + cycle + endif + call read_vardata(dset,trim(dset%variables(nvar)%name),values_2d) + call mpi_allreduce(values_2d,values_2d_avg,lonb*latb,mpi_real4,mpi_sum,new_comm,iret) + values_2d_avg = values_2d_avg * rnanals + if (mype == 0) then + print *,'writing ens mean ',trim(dset%variables(nvar)%name) + call write_vardata(dseto,trim(dset%variables(nvar)%name),values_2d_avg) + endif + enddo + if (mype == 0) call close_dataset(dseto) + deallocate(values_2d,values_2d_avg) endif - ! Jump here if more mpi processors than files to process else write(6,*) 'No files to process for mpi task = ',mype @@ -291,7 +342,7 @@ program getsfcensmeanp 100 continue call mpi_barrier(mpi_comm_world,iret) - if (mype1 <= nanals .and. .not.nemsio .and. .not.sfcio) then + if (mype1 <= nanals .and. .not. ncio .and. .not.nemsio .and. .not.sfcio) then write(6,*)'***ERROR*** invalid surface file format' call MPI_Abort(MPI_COMM_WORLD,98,iret) stop diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsfcnstensupdp.fd/CMakeLists.txt index 4955df6e7f..e88f495651 100644 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/getsfcnstensupdp.fd/CMakeLists.txt @@ -10,6 +10,4 @@ if(BUILD_UTIL) 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/getsigensmeanp_smooth.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/CMakeLists.txt index 0b169f4111..0e41e9a848 100644 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/CMakeLists.txt @@ -7,6 +7,6 @@ if(BUILD_UTIL) 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} ) + include_directories( ${NEMSIOINC} ${SIGIOINC} ${NETCDF_INCLUDES} ${FV3GFS_NCIO_INCS}) + target_link_libraries( getsigensmeanp_smooth.x ${BACIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${SIGIO_LIBRARY} ${W3NCO_4_LIBRARY} ${SP_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${FV3GFS_NCIO_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/getsigensmeanp_smooth_ncep.f90 b/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/getsigensmeanp_smooth_ncep.f90 index b341336861..cb622350b1 100644 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/getsigensmeanp_smooth_ncep.f90 +++ b/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/getsigensmeanp_smooth_ncep.f90 @@ -20,12 +20,17 @@ program getsigensmeanp_smooth ! !$$$ + use netcdf use sigio_module, only: sigio_head,sigio_data,sigio_srohdc, & sigio_swohdc,sigio_aldata,sigio_axdata use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_charkind8, & nemsio_readrec,nemsio_writerec, & nemsio_readrecv,nemsio_writerecv + use module_fv3gfs_ncio, only: open_dataset, create_dataset, read_attribute, & + Dataset, Dimension, close_dataset, has_attr, & + read_vardata, write_attribute, write_vardata, & + get_dim, quantize_data, has_var implicit none @@ -33,31 +38,40 @@ program getsigensmeanp_smooth integer,parameter :: iunit=21 integer,parameter :: window=1 ! cosine bell window for smoothing - logical :: lexist,dosmooth,nemsio,sigio + logical :: lexist,dosmooth,nemsio,sigio,ncio,increment,quantize,write_spread_ncio logical,allocatable,dimension(:) :: notuv,smooth_fld character(nemsio_charkind8) :: dtype character(len=3) :: charnanal - character(len=500) :: filenamein,filenameout,filenameouts,datapath,fileprefix,fname + character(len=500) :: filenamein,filenameout,filenameouts,datapath,fileprefix,fname,& + filenameoutsprd character(len=16),allocatable,dimension(:) :: recnam - integer :: iret,nlevs,ntrac,ntrunc,nanals,ngrd,k + integer :: iret,nlevs,ntrac,ntrunc,nanals,ngrd,k,ndims,nvar,nbits integer :: nsize,nsize2,nsize3,nsize3t integer :: mype,mype1,npe,orig_group,new_group,new_comm integer :: nrec,latb,lonb,npts,n,idrt integer,allocatable,dimension(:) :: new_group_members,reclev,krecu,krecv integer,allocatable,dimension(:) :: smoothparm - real(8) :: rnanals + real(8) :: rnanals,rnanalsm1,t1,t2 real(8),allocatable,dimension(:,:,:) :: smoothfact + real(4),allocatable, dimension(:,:,:) :: values_3d, values_3d_avg, & + values_3d_tmp, values_3d_sprd + real(4),allocatable, dimension(:,:,:) :: values_3dv, values_3dv_avg, & + values_3dv_tmp, values_3dv_sprd real(4),allocatable,dimension(:) :: sigdatapert_ps,sigdatapert_z,sigdatapert_d,& sigdatapert_t,sigdatapert_q,sigdatapert_oz,& sigdatapert_cw - real(4),allocatable,dimension(:,:) :: rwork_mem,rwork_avg + real(4),allocatable,dimension(:,:) :: rwork_mem,rwork_avg, values_2d, & + values_2d_sprd,values_2d_avg, values_2d_tmp real(4),allocatable,dimension(:) :: rwork_hgt real(4),allocatable,dimension(:) :: rwork_lev,rwork_lev2,rwork_spc,rwork_spc2 + real(4) compress_err type(sigio_head) :: sigheadi,sigheadm type(sigio_data) :: sigdatai,sigdatam type(nemsio_gfile) :: gfile,gfileo,gfileos + type(Dataset) :: dset,dseto,dseto_smooth,dseto_sprd + type(Dimension) :: londim,latdim,levdim ! mpi definitions. include 'mpif.h' @@ -80,7 +94,17 @@ program getsigensmeanp_smooth rnanals = nanals rnanals = 1.0_8/rnanals + rnanalsm1 = nanals-1 + rnanalsm1 = 1.0_8/rnanalsm1 filenameout = trim(adjustl(datapath)) // trim(adjustl(filenameout)) + ! if a 5th arg present, it's a filename to write out ensemble spread + ! (only used for ncio) + if (nargs() > 5) then + call getarg(5,filenameoutsprd) + write_spread_ncio = .true. + if (mype == 0) print *,'computing ensemble spread' + filenameoutsprd = trim(adjustl(datapath)) // trim(adjustl(filenameoutsprd)) + endif if ( mype == 0 ) then write(6,'(a)') 'Command line input' @@ -88,11 +112,14 @@ program getsigensmeanp_smooth write(6,'(a,a)')' filenameout = ',trim(filenameout) write(6,'(a,a)')' fileprefix = ',trim(fileprefix) write(6,'(a,a)')' nanals = ',trim(charnanal) + if (write_spread_ncio) then + write(6,'(a,a)')' filenameoutsprd = ',trim(filenameoutsprd) + endif write(6,'(a)') ' ' endif if ( npe < nanals ) then - write(6,'(2(a,i4))')'***ERROR*** npe too small. npe = ',npe,' < nanals = ',nanals + write(6,'(2(a,i4))')'***FATAL ERROR*** npe too small. npe = ',npe,' < nanals = ',nanals call mpi_abort(mpi_comm_world,99,iret) stop end if @@ -108,73 +135,141 @@ program getsigensmeanp_smooth call mpi_group_incl(orig_group,nanals,new_group_members,new_group,iret) call mpi_comm_create(mpi_comm_world,new_group,new_comm,iret) if ( iret /= 0 ) then - write(6,'(a,i5)')'***ERROR*** after mpi_comm_create with iret = ',iret + write(6,'(a,i5)')'***FATAL ERROR*** after mpi_comm_create with iret = ',iret call mpi_abort(mpi_comm_world,101,iret) endif sigio = .false. nemsio = .false. + ncio = .false. + increment = .false. ! Process input files (one file per task) if ( mype1 <= nanals ) then - call nemsio_init(iret=iret) - write(charnanal,'(i3.3)') mype1 filenamein = trim(adjustl(datapath)) // & trim(adjustl(fileprefix)) // '_mem' // charnanal + dset = open_dataset(filenamein,errcode=iret) + if (iret == 0) then + ! this is a netCDF file but now we need to determine + ! if it is a netCDF analysis or increment + ! going to assume all increment files will have temperature increment + if (has_var(dset,'T_inc')) then + increment = .true. + else ! otherwise assume it is a netCDF analysis file + ncio = .true. + end if + endif + if (.not. ncio .and. .not. increment ) then + call nemsio_init(iret=iret) + call nemsio_open(gfile,trim(filenamein),'READ',iret=iret) + if (iret == 0) then + nemsio = .true. + else + nemsio = .false. + endif + endif + if (.not. ncio .and. .not. nemsio .and. .not. increment) then + call sigio_srohdc(iunit,trim(filenamein),sigheadi,sigdatai,iret) + if (iret == 0) then + sigio = .true. + else + sigio = .false. + endif + endif + + if ( .not. ncio .and. .not. nemsio .and. .not. sigio .and. .not. increment) goto 100 + ! Read each ensemble member - call sigio_srohdc(iunit,trim(filenamein),sigheadi,sigdatai,iret) - if ( iret == 0 ) then - sigio = .true. - write(6,'(3a,i5)')'Read sigio ',trim(filenamein),' iret = ',iret + if (ncio) then + if (mype == 0) write(6,*) 'Read netcdf' + londim = get_dim(dset,'grid_xt'); lonb = londim%len + latdim = get_dim(dset,'grid_yt'); latb = latdim%len + levdim = get_dim(dset,'pfull'); nlevs = levdim%len + call read_attribute(dset, 'ncnsto', ntrac) + ntrunc = latb-2 + endif + if (increment) then + if (mype == 0) write(6,*) 'Read netCDF increment' + londim = get_dim(dset,'lon'); lonb = londim%len + latdim = get_dim(dset,'lat'); latb = latdim%len + levdim = get_dim(dset,'lev'); nlevs = levdim%len + ntrac = 9999 + ntrunc = latb-2 + endif + if (sigio) then + if (mype == 0) write(6,*) 'Read sigio' ntrunc = sigheadi%jcap ntrac = sigheadi%ntrac nlevs = sigheadi%levs - else - call nemsio_open(gfile,trim(filenamein),'READ',iret=iret) - if ( iret == 0 ) then - nemsio = .true. - call nemsio_getfilehead(gfile, nrec=nrec, jcap=ntrunc, & - dimx=lonb, dimy=latb, dimz=nlevs, ntrac=ntrac, gdatatype=dtype, iret=iret) - write(6,'(5a,i5)')'Read nemsio ',trim(filenamein), ' dtype = ', trim(adjustl(dtype)),' iret = ',iret - allocate(reclev(nrec),recnam(nrec)) - call nemsio_getfilehead(gfile,reclev=reclev,iret=iret) - call nemsio_getfilehead(gfile,recname=recnam,iret=iret) - if ( ntrunc < 0 ) ntrunc = latb - 2 - else - write(6,'(3a)')'***ERROR*** ',trim(filenamein),' contains unrecognized format. ABORT!' - endif endif - if ( .not. nemsio .and. .not. sigio ) goto 100 - if ( mype == 0 ) then - write(6,'(a)') ' ' - write(6,'(2(a,l1))')'Computing ensemble mean with nemsio = ',nemsio,', sigio = ',sigio - write(6,'(a)') ' ' + if (nemsio) then + call nemsio_getfilehead(gfile, nrec=nrec, jcap=ntrunc, & + dimx=lonb, dimy=latb, dimz=nlevs, ntrac=ntrac, gdatatype=dtype, iret=iret) + write(6,'(5a,i5)')'Read nemsio ',trim(filenamein), ' dtype = ', trim(adjustl(dtype)),' iret = ',iret + allocate(reclev(nrec),recnam(nrec)) + call nemsio_getfilehead(gfile,reclev=reclev,iret=iret) + call nemsio_getfilehead(gfile,recname=recnam,iret=iret) + if ( ntrunc < 0 ) ntrunc = latb - 2 endif - nsize2 = (ntrunc+1)*(ntrunc+2) - nsize3 = nsize2*nlevs - nsize3t = nsize3*ntrac if ( mype == 0 ) then write(6,'(a)') ' ' write(6,'(2a)') 'Read header information from ',trim(filenamein) write(6,'(a,i9)')' ntrunc = ',ntrunc write(6,'(a,i9)')' ntrac = ',ntrac write(6,'(a,i9)')' nlevs = ',nlevs - write(6,'(a,i9)')' nsize2 = ',nsize2 - write(6,'(a,i9)')' nsize3 = ',nsize3 - write(6,'(a,i9)')' nsize3t = ',nsize3t - if ( nemsio ) then + if ( ncio .or. nemsio .or. increment ) then write(6,'(a,i9)')' lonb = ',lonb write(6,'(a,i9)')' latb = ',latb + endif + if ( nemsio ) then write(6,'(a,i9)')' nrec = ',nrec endif write(6,'(a)') ' ' endif +! Read smoothing parameters, if available + fname='hybens_smoothinfo' + inquire(file=trim(fname),exist=lexist) + if ( lexist ) then + allocate(smoothparm(nlevs)) + smoothparm = -1 + open(9,form='formatted',file=fname) + do k=1,nlevs + read(9,'(i3)') smoothparm(k) + enddo + close(9) + dosmooth = maxval(smoothparm)>0 + else + if ( mype == 0 ) write(6,'(a)')'***WARNING*** hybens_smoothinfo not found - no smoothing' + dosmooth = .false. + endif + if ( mype == 0 ) write(6,'(a,l1)')'dosmooth = ',dosmooth + +! Abort if smoothing requested with increment option + if (dosmooth .and. increment) then + write(6,'(a,l7,a,l7)')'***FATAL ERROR*** can not run dosmooth ',dosmooth,' and increment ',increment + call mpi_abort(mpi_comm_world,100,iret) + stop + endif + + if ( dosmooth ) then +! Set up smoother + allocate(smoothfact(0:ntrunc,0:ntrunc,nlevs)) + smoothfact = 1.0_8 + call setup_smooth(ntrunc,nlevs,smoothparm,window,smoothfact) + filenameouts = trim(adjustl(datapath)) // & + trim(adjustl(fileprefix)) // 's' // '_mem' // charnanal + idrt = 4 + endif + if ( sigio ) then + nsize2 = (ntrunc+1)*(ntrunc+2) + nsize3 = nsize2*nlevs + nsize3t = nsize3*ntrac ! Compute ensemble sums. call sigio_aldata(sigheadi,sigdatam,iret) @@ -261,36 +356,318 @@ program getsigensmeanp_smooth write(6,'(3a,i5)')'Write nemsio ensemble mean ',trim(filenameout),' iret = ', iret endif - endif + else if (ncio) then -! Read smoothing parameters, if available - fname='hybens_smoothinfo' - inquire(file=trim(fname),exist=lexist) - if ( lexist ) then - allocate(smoothparm(nlevs)) - smoothparm = -1 - open(9,form='formatted',file=fname) - do k=1,nlevs - read(9,'(i3)') smoothparm(k) - enddo - close(9) - dosmooth = maxval(smoothparm)>0 - else - if ( mype == 0 ) write(6,'(a)')'***WARNING*** hybens_smoothinfo not found - no smoothing' - dosmooth = .false. - endif - if ( mype == 0 ) write(6,'(a,l1)')'dosmooth = ',dosmooth + if (mype == 0) then + t1 = mpi_wtime() + dseto = create_dataset(filenameout, dset, copy_vardata=.true.) + if (write_spread_ncio) then + dseto_sprd = create_dataset(filenameoutsprd, dset, copy_vardata=.true.) + endif + endif + if (dosmooth) then + dseto_smooth = create_dataset(filenameouts, dset, copy_vardata=.true.) + endif + allocate(values_2d_avg(lonb,latb)) + allocate(values_2d_tmp(lonb,latb)) + if (dosmooth) then + allocate(rwork_spc((ntrunc+1)*(ntrunc+2)),rwork_spc2((ntrunc+1)*(ntrunc+2))) + endif + if (write_spread_ncio) allocate(values_2d_sprd(lonb,latb)) + do nvar=1,dset%nvars + ! if smoothing is on, u&v done together. + if (dosmooth .and. trim(dset%variables(nvar)%name) == 'vgrd') cycle + ndims = dset%variables(nvar)%ndims + if (ndims > 2) then + if (ndims == 3 .and. trim(dset%variables(nvar)%name) /= 'hgtsfc') then + ! pressfc + if (mype == 0) print *,'processing ',trim(dset%variables(nvar)%name) + call read_vardata(dset,trim(dset%variables(nvar)%name),values_2d) + call mpi_allreduce(values_2d,values_2d_avg,lonb*latb,mpi_real4,mpi_sum,new_comm,iret) + ! ens mean + values_2d_avg = values_2d_avg*rnanals + if (write_spread_ncio) then + ! ens spread + values_2d_tmp = values_2d - values_2d_avg ! ens pert + values_2d_tmp = values_2d_tmp**2 + call mpi_reduce(values_2d_tmp,values_2d_sprd,lonb*latb,mpi_real4,mpi_sum,0,new_comm,iret) + values_2d_sprd= sqrt(values_2d_sprd*rnanalsm1) + if (mype == 0) print *,trim(dset%variables(nvar)%name),' min/max spread',minval(values_2d_sprd),maxval(values_2d_sprd) + endif + if (has_attr(dset, 'nbits', trim(dset%variables(nvar)%name))) then + call read_attribute(dset, 'nbits', nbits, & + trim(dset%variables(nvar)%name)) + quantize = .true. + if (nbits < 1) quantize = .false. + else + quantize = .false. + endif + ! smooth ens pert and write out? + ! don't smooth 2d fields + if (dosmooth) then + ! don't smooth 2d fields + !values_2d = values_2d - values_2d_avg ! ens pert + !call sptez(0,ntrunc,idrt,lonb,latb,rwork_spc,values_2d,-1) + !call smooth(rwork_spc,ntrunc,smoothfact(:,:,nlevs)) + !call sptez(0,ntrunc,idrt,lonb,latb,rwork_spc,values_2d,1) + !values_2d = values_2d + values_2d_avg ! add mean back + if (quantize) then + values_2d_tmp = values_2d + call quantize_data(values_2d_tmp, values_2d, nbits, compress_err) + call write_attribute(dseto_smooth,& + 'max_abs_compression_error',compress_err,trim(dset%variables(nvar)%name)) + endif + call write_vardata(dseto_smooth,trim(dset%variables(nvar)%name),values_2d) + endif + ! write ens mean + if (mype == 0) then + if (quantize) then + values_2d_tmp = values_2d_avg + call quantize_data(values_2d_tmp, values_2d_avg, nbits, compress_err) + call write_attribute(dseto,& + 'max_abs_compression_error',compress_err,trim(dset%variables(nvar)%name)) + endif + call write_vardata(dseto,trim(dset%variables(nvar)%name),values_2d_avg) + if (write_spread_ncio) then + if (quantize) then + values_2d_tmp = values_2d_sprd + call quantize_data(values_2d_tmp, values_2d_sprd, nbits, compress_err) + call write_attribute(dseto_sprd,& + 'max_abs_compression_error',compress_err,trim(dset%variables(nvar)%name)) + endif + call write_vardata(dseto_sprd,trim(dset%variables(nvar)%name),values_2d_sprd) + endif + endif + else if (ndims == 4) then + ! 3d variables (extra dim is time) + call read_vardata(dset,trim(dset%variables(nvar)%name),values_3d) + if (allocated(values_3d_avg)) deallocate(values_3d_avg) + allocate(values_3d_avg, mold=values_3d) + if (allocated(values_3d_tmp)) deallocate(values_3d_tmp) + allocate(values_3d_tmp, mold=values_3d_avg) + if (write_spread_ncio) then + if (allocated(values_3d_sprd)) deallocate(values_3d_sprd) + allocate(values_3d_sprd, mold=values_3d_avg) + endif + if (mype == 0) print *,'processing ',trim(dset%variables(nvar)%name) + call mpi_allreduce(values_3d,values_3d_avg,lonb*latb*nlevs,mpi_real4,mpi_sum,new_comm,iret) + values_3d_avg = values_3d_avg*rnanals + if (write_spread_ncio) then + ! ens spread + values_3d_tmp = values_3d - values_3d_avg ! ens pert + values_3d_tmp = values_3d_tmp**2 + call mpi_reduce(values_3d_tmp,values_3d_sprd,lonb*latb*nlevs,mpi_real4,mpi_sum,0,new_comm,iret) + values_3d_sprd= sqrt(values_3d_sprd*rnanalsm1) + if (mype == 0) print *,trim(dset%variables(nvar)%name),' min/max spread',minval(values_3d_sprd),maxval(values_3d_sprd) + endif + if (has_attr(dset, 'nbits', trim(dset%variables(nvar)%name))) then + call read_attribute(dset, 'nbits', nbits, & + trim(dset%variables(nvar)%name)) + quantize = .true. + if (nbits < 1) quantize = .false. + else + quantize = .false. + endif + ! if smoothing on, read u and v together + if (dosmooth .and. trim(dset%variables(nvar)%name) == 'ugrd') then + call read_vardata(dset,'vgrd',values_3dv) + if (allocated(values_3dv_avg)) deallocate(values_3dv_avg) + allocate(values_3dv_avg, mold=values_3dv) + if (allocated(values_3dv_tmp)) deallocate(values_3dv_tmp) + allocate(values_3dv_tmp, mold=values_3dv) + if (allocated(values_3dv_sprd)) deallocate(values_3dv_sprd) + allocate(values_3dv_sprd, mold=values_3dv) + if (mype == 0) print *,'processing vgrd' + call mpi_allreduce(values_3dv,values_3dv_avg,lonb*latb*nlevs,mpi_real4,mpi_sum,new_comm,iret) + values_3dv_avg = values_3dv_avg*rnanals + if (write_spread_ncio) then + ! ens spread + values_3dv_tmp = values_3dv - values_3dv_avg ! ens pert + values_3dv_tmp = values_3dv_tmp**2 + call mpi_reduce(values_3d_tmp,values_3dv_sprd,lonb*latb*nlevs,mpi_real4,mpi_sum,0,new_comm,iret) + values_3dv_sprd= sqrt(values_3dv_sprd*rnanalsm1) + if (mype == 0) print *,'vgrd min/max spread',minval(values_3d_sprd),maxval(values_3d_sprd) + endif + endif + ! smooth ens pert and write out? + if (dosmooth) then + if (trim(dset%variables(nvar)%name) == 'ugrd') then + ! do u,v together +!$omp parallel do schedule(dynamic,1) private(k,rwork_spc,rwork_spc2) + do k=1,nlevs + if ( smoothparm(nlevs-k+1) > 0 ) then + values_3d(:,:,k) = values_3d(:,:,k) - values_3d_avg(:,:,k) ! ens pert + values_3dv(:,:,k) = values_3dv(:,:,k) - values_3dv_avg(:,:,k) ! ens pert + call sptezv(0,ntrunc,idrt,lonb,latb,rwork_spc,rwork_spc2,& + values_3d(:,:,k),values_3dv(:,:,k),-1) + call smooth(rwork_spc, ntrunc,smoothfact(:,:,nlevs-k+1)) + call smooth(rwork_spc2,ntrunc,smoothfact(:,:,nlevs-k+1)) + call sptezv(0,ntrunc,idrt,lonb,latb,rwork_spc,rwork_spc2,& + values_3d(:,:,k),values_3dv(:,:,k),1) + values_3d(:,:,k) = values_3d(:,:,k) + values_3d_avg(:,:,k) ! add mean back + values_3dv(:,:,k) = values_3dv(:,:,k) + values_3dv_avg(:,:,k) ! add mean back + endif + enddo + if (quantize) then + values_3d_tmp = values_3d + values_3dv_tmp = values_3dv + call quantize_data(values_3d_tmp, values_3d, nbits, compress_err) + call write_attribute(dseto_smooth,& + 'max_abs_compression_error',compress_err,'ugrd') + call quantize_data(values_3dv_tmp, values_3dv, nbits, compress_err) + call write_attribute(dseto_smooth,& + 'max_abs_compression_error',compress_err,'vgrd') + endif + call write_vardata(dseto_smooth,'ugrd',values_3d) + call write_vardata(dseto_smooth,'vgrd',values_3dv) + else + ! do scalars. + if (trim(dset%variables(nvar)%name) /= 'ugrd' .and. & + trim(dset%variables(nvar)%name) /= 'dzdt' .and. & + trim(dset%variables(nvar)%name) /= 'delz' .and. & + trim(dset%variables(nvar)%name) /= 'dpres' .and. & + trim(dset%variables(nvar)%name) /= 'vgrd') then +!$omp parallel do schedule(dynamic,1) private(k,rwork_spc) + do k=1,nlevs + if ( smoothparm(nlevs-k+1) > 0 ) then + values_3d(:,:,k) = values_3d(:,:,k) - values_3d_avg(:,:,k) ! ens pert + call sptez(0,ntrunc,idrt,lonb,latb,rwork_spc,values_3d(:,:,k),-1) + call smooth(rwork_spc,ntrunc,smoothfact(:,:,nlevs-k+1)) + call sptez(0,ntrunc,idrt,lonb,latb,rwork_spc,values_3d(:,:,k),1) + values_3d(:,:,k) = values_3d(:,:,k) + values_3d_avg(:,:,k) ! add mean back + endif + enddo + endif + if (quantize) then + values_3d_tmp = values_3d + call quantize_data(values_3d_tmp, values_3d, nbits, compress_err) + call write_attribute(dseto_smooth,& + 'max_abs_compression_error',compress_err,trim(dset%variables(nvar)%name)) + endif + call write_vardata(dseto_smooth,trim(dset%variables(nvar)%name),values_3d) + endif + endif + if (mype == 0) then + if (quantize) then + values_3d_tmp = values_3d_avg + call quantize_data(values_3d_tmp, values_3d_avg, nbits, compress_err) + call write_attribute(dseto,& + 'max_abs_compression_error',compress_err,trim(dset%variables(nvar)%name)) + endif + call write_vardata(dseto,trim(dset%variables(nvar)%name),values_3d_avg) + ! if smoothing on, write u and v together + if (dosmooth .and. trim(dset%variables(nvar)%name) == 'ugrd') then + if (quantize) then + values_3dv_tmp = values_3dv_avg + call quantize_data(values_3dv_tmp, values_3dv_avg, nbits, compress_err) + call write_attribute(dseto,& + 'max_abs_compression_error',compress_err,'vgrd') + endif + call write_vardata(dseto,'vgrd',values_3dv_avg) + endif + if (write_spread_ncio) then + if (quantize) then + values_3d_tmp = values_3d_sprd + call quantize_data(values_3d_tmp, values_3d_sprd, nbits, compress_err) + call write_attribute(dseto_sprd,& + 'max_abs_compression_error',compress_err,trim(dset%variables(nvar)%name)) + endif + call write_vardata(dseto_sprd,trim(dset%variables(nvar)%name),values_3d_sprd) + ! if smoothing on, write u and v together + if (dosmooth .and. trim(dset%variables(nvar)%name) == 'ugrd') then + if (quantize) then + values_3dv_tmp = values_3dv_sprd + call quantize_data(values_3dv_tmp, values_3dv_sprd, nbits, compress_err) + call write_attribute(dseto_sprd,& + 'max_abs_compression_error',compress_err,'vgrd') + endif + call write_vardata(dseto_sprd,'vgrd',values_3dv_sprd) + endif + endif + endif + endif + endif ! ndims > 2 + enddo ! nvars + deallocate(values_2d, values_3d, values_2d_avg, values_3d_avg) + deallocate(values_2d_tmp, values_3d_tmp) + if (dosmooth) then + deallocate(rwork_spc) + call close_dataset(dseto_smooth) + endif + if (write_spread_ncio) then + deallocate(values_2d_sprd, values_3d_sprd) + endif + if (mype == 0) then + call close_dataset(dseto) + t2 = mpi_wtime() + print *,'time to write ens mean on root',t2-t1 + write(6,'(3a,i5)')'Write ncio ensemble mean ',trim(filenameout),' iret = ', iret + if (write_spread_ncio) then + call close_dataset(dseto_sprd) + write(6,'(3a,i5)')'Write ncio ensemble spread ',trim(filenameoutsprd),' iret = ', iret + endif + endif -! If smoothing requested, loop over and smooth analysis files - if ( dosmooth ) then + else if (increment) then -! Set up smoother - allocate(smoothfact(0:ntrunc,0:ntrunc,nlevs)) - smoothfact = 1.0_8 - call setup_smooth(ntrunc,nlevs,smoothparm,window,smoothfact) + if (mype == 0) then + t1 = mpi_wtime() + dseto = create_dataset(filenameout, dset, copy_vardata=.true.) + if (write_spread_ncio) then + dseto_sprd = create_dataset(filenameoutsprd, dset, copy_vardata=.true.) + endif + endif + do nvar=1,dset%nvars + ndims = dset%variables(nvar)%ndims + if (ndims == 3) then + call read_vardata(dset,trim(dset%variables(nvar)%name),values_3d) + if (allocated(values_3d_avg)) deallocate(values_3d_avg) + allocate(values_3d_avg, mold=values_3d) + if (allocated(values_3d_tmp)) deallocate(values_3d_tmp) + allocate(values_3d_tmp, mold=values_3d_avg) + if (write_spread_ncio) then + if (allocated(values_3d_sprd)) deallocate(values_3d_sprd) + allocate(values_3d_sprd, mold=values_3d_avg) + endif + if (mype == 0) print *,'processing ',trim(dset%variables(nvar)%name) + call mpi_allreduce(values_3d,values_3d_avg,lonb*latb*nlevs,mpi_real4,mpi_sum,new_comm,iret) + values_3d_avg = values_3d_avg*rnanals + if (write_spread_ncio) then + ! ens spread + values_3d_tmp = values_3d - values_3d_avg ! ens pert + values_3d_tmp = values_3d_tmp**2 + call mpi_reduce(values_3d_tmp,values_3d_sprd,lonb*latb*nlevs,mpi_real4,mpi_sum,0,new_comm,iret) + values_3d_sprd= sqrt(values_3d_sprd*rnanalsm1) + if (mype == 0) print *,trim(dset%variables(nvar)%name),' min/max spread',minval(values_3d_sprd),maxval(values_3d_sprd) + endif + if (mype == 0) then + call write_vardata(dseto,trim(dset%variables(nvar)%name),values_3d_avg) + if (write_spread_ncio) then + call write_vardata(dseto_sprd,trim(dset%variables(nvar)%name),values_3d_sprd) + end if + end if + end if ! end if 3D var + end do ! end loop through variables + deallocate(values_3d, values_3d_avg) + deallocate(values_3d_tmp) + if (write_spread_ncio) then + deallocate(values_3d_sprd) + endif + if (mype == 0) then + call close_dataset(dseto) + t2 = mpi_wtime() + print *,'time to write ens mean on root',t2-t1 + write(6,'(3a,i5)')'Write increment ensemble mean ',trim(filenameout),' iret = ', iret + if (write_spread_ncio) then + call close_dataset(dseto_sprd) + write(6,'(3a,i5)')'Write increment ensemble spread ',trim(filenameoutsprd),' iret = ', iret + endif + endif + endif - filenameouts = trim(adjustl(datapath)) // & - trim(adjustl(fileprefix)) // 's' // '_mem' // charnanal +! If smoothing requested, loop over and smooth analysis fields (for sigio and +! nemsio) + if ( dosmooth ) then if ( sigio ) then @@ -390,7 +767,7 @@ program getsigensmeanp_smooth endif ! Deallocate smoothing factors - deallocate(smoothfact) + if (allocated(smoothfact)) deallocate(smoothfact) ! End of smoothing block endif @@ -406,6 +783,8 @@ program getsigensmeanp_smooth if (allocated(rwork_avg)) deallocate(rwork_avg) if (allocated(rwork_hgt)) deallocate(rwork_hgt) deallocate(krecu,krecv,notuv,smooth_fld) + elseif (ncio) then + call close_dataset(dset) endif ! Jump here if more mpi processors than files to process @@ -416,8 +795,8 @@ program getsigensmeanp_smooth 100 continue call mpi_barrier(mpi_comm_world,iret) - if ( mype1 <= nanals .and. .not. nemsio .and. .not. sigio ) then - write(6,'(a)')'***ERROR*** invalid atmospheric file format' + if ( mype1 <= nanals .and. .not. nemsio .and. .not. sigio .and. .not. ncio .and. .not. increment) then + write(6,'(a)')'***FATAL ERROR*** invalid atmospheric file format' call mpi_abort(mpi_comm_world,98,iret) stop endif @@ -490,4 +869,3 @@ subroutine setup_smooth(ntrunc,nlevs,smoothparm,window,smoothfact) enddo m_loop enddo k_loop end subroutine setup_smooth - diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsigensstatp.fd/CMakeLists.txt index bc7e3fbb18..c888c52710 100644 --- a/util/EnKF/gfs/src/getsigensstatp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/getsigensstatp.fd/CMakeLists.txt @@ -6,6 +6,6 @@ if(BUILD_UTIL) set_target_properties( getsigensstatp.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) 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} ) + include_directories( ${NETCDF_INCLUDES} ${SIGIOINC} ${NEMSIOINC} ${MPI_Fortran_INCLUDE_PATH} ${FV3GFS_NCIO_INCS}) + 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} ${FV3GFS_NCIO_LIBRARIES}) endif() diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/getsigensstatp.f90 b/util/EnKF/gfs/src/getsigensstatp.fd/getsigensstatp.f90 index 773609bef3..ecc76ffdc8 100644 --- a/util/EnKF/gfs/src/getsigensstatp.fd/getsigensstatp.f90 +++ b/util/EnKF/gfs/src/getsigensstatp.fd/getsigensstatp.f90 @@ -34,6 +34,11 @@ program getsigensstatp use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close, & nemsio_gfile,nemsio_getfilehead,nemsio_charkind8, & nemsio_readrec,nemsio_readrecv + use module_fv3gfs_ncio, only: open_dataset, create_dataset, read_attribute, & + Dataset, Dimension, close_dataset, & + read_vardata, write_attribute, write_vardata, & + get_dim, quantize_data + implicit none @@ -53,13 +58,17 @@ program getsigensstatp integer,dimension(:),allocatable :: new_group_members,reclev real(r_single),allocatable,dimension(:,:) :: rwork_mem,rwork_avg real(r_single),allocatable,dimension(:) :: glats,gwts - logical :: sigio,nemsio - logical :: do_icmr = .false. + real(4), allocatable, dimension(:,:,:) :: values_3d + real(4), allocatable, dimension(:,:) :: values_2d + logical :: sigio,nemsio,ncio +! logical :: do_icmr = .false. logical :: do_hydro = .false. type(sigio_head) :: sigheadi type(sigio_data) :: sigdatai type(nemsio_gfile) :: gfile + type(Dataset) :: dset + type(Dimension) :: londim,latdim,levdim ! Initialize mpi, mype is process number, npe is total number of processes. call mpi_init(iret) @@ -118,48 +127,77 @@ program getsigensstatp nemsio = .false. sigio = .false. + ncio = .false. ! Process input files (one file per task) if ( mype1 <= nanals ) then - call nemsio_init(iret=iret) - write(charnanal,'(i3.3)') mype1 filenamein = trim(adjustl(datapath)) // trim(adjustl(filepref)) // '_mem' // charnanal + dset = open_dataset(filenamein,errcode=iret) + if (iret == 0) then + ncio = .true. + else + ncio = .false. + end if + if (.not. ncio) then + call nemsio_init(iret=iret) + call nemsio_open(gfile,trim(filenamein),'READ',iret=iret) + if (iret == 0) then + nemsio = .true. + else + nemsio = .false. + endif + endif + if (.not. ncio .and. .not. nemsio) then + call sigio_srohdc(iunit,trim(filenamein),sigheadi,sigdatai,iret) + if (iret == 0) then + sigio = .true. + else + sigio = .false. + endif + endif + + if ( .not. ncio .and. .not. nemsio .and. .not. sigio ) then + write(6,'(3a)')'***ERROR*** ',trim(filenamein),' contains unrecognized file format. ABORT!' + call mpi_abort(mpi_comm_world,99,iret) + stop + end if + +! Read each ensemble member ! Read each ensemble member - call sigio_srohdc(iunit,trim(adjustl(filenamein)),sigheadi,sigdatai,iret) - if ( iret == 0 ) then - sigio = .true. + if (ncio) then + if (mype == 0) write(6,*) 'Read netcdf ',trim(filenamein) + londim = get_dim(dset,'grid_xt'); lonb = londim%len + latdim = get_dim(dset,'grid_yt'); latb = latdim%len + levdim = get_dim(dset,'pfull'); nlevs = levdim%len + call read_attribute(dset, 'ncnsto', ntrac) + ntrunc = latb-2 + end if + if (sigio) then write(6,'(3a,i5)')'Read sigio ',trim(filenamein),' iret = ',iret ntrunc = sigheadi%jcap ntrac = sigheadi%ntrac nlevs = sigheadi%levs latb = sigheadi%latf lonb = sigheadi%lonf - else - call nemsio_open(gfile,trim(filenamein),'READ',iret=iret) - if ( iret == 0 ) then - nemsio = .true. - call nemsio_getfilehead(gfile, nrec=nrec, jcap=ntrunc, & - dimx=lonb, dimy=latb, dimz=nlevs, ntrac=ntrac, gdatatype=dtype, iret=iret) - write(6,'(5a,i5)')'Read nemsio ',trim(filenamein), ' dtype = ', trim(adjustl(dtype)),' iret = ',iret - if ( ntrunc < 0 ) ntrunc = latb - 2 - allocate(reclev(nrec),recnam(nrec)) - call nemsio_getfilehead(gfile,reclev=reclev,iret=iret) - call nemsio_getfilehead(gfile,recname=recnam,iret=iret) - else - write(6,'(3a)')'***ERROR*** ',trim(filenamein),' contains unrecognized file format. ABORT!' - 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 + end if + if (nemsio) then + call nemsio_getfilehead(gfile, nrec=nrec, jcap=ntrunc, & + dimx=lonb, dimy=latb, dimz=nlevs, ntrac=ntrac, gdatatype=dtype, iret=iret) + write(6,'(5a,i5)')'Read nemsio ',trim(filenamein), ' dtype = ', trim(adjustl(dtype)),' iret = ',iret + if ( ntrunc < 0 ) ntrunc = latb - 2 + allocate(reclev(nrec),recnam(nrec)) + call nemsio_getfilehead(gfile,reclev=reclev,iret=iret) + call nemsio_getfilehead(gfile,recname=recnam,iret=iret) + !do_icmr = variable_exist('icmr') + do_hydro = .false. ! set to false to keep the file size small endif if ( mype == 0 ) then write(6,'(a)') ' ' - write(6,'(2(a,l1))')'Computing ensemble mean and spread with nemsio = ',nemsio,' , sigio = ',sigio + write(6,'(2(a,l1))')'Computing ensemble mean and spread with nemsio = ',nemsio,' , sigio = ',sigio, ' , ncio = ',ncio write(6,'(a)') ' ' endif @@ -247,6 +285,47 @@ program getsigensstatp enddo call nemsio_close(gfile,iret=iret) + elseif ( ncio ) then + call read_vardata(dset,'pressfc',values_2d) + rwork_mem(:,1) = reshape(values_2d,(/npts/)) + deallocate(values_2d) + call read_vardata(dset,'ugrd',values_3d) + do k = 1,nlevs + krecu = 1 + 0*nlevs + k + rwork_mem(:,krecu) = reshape(values_3d(:,:,k),(/npts/)) + end do + call read_vardata(dset,'vgrd',values_3d) + do k = 1,nlevs + krecv = 1 + 1*nlevs + k + rwork_mem(:,krecv) = reshape(values_3d(:,:,k),(/npts/)) + end do + call read_vardata(dset,'tmp',values_3d) + do k = 1,nlevs + krect = 1 + 2*nlevs + k + rwork_mem(:,krect) = reshape(values_3d(:,:,k),(/npts/)) + end do + call read_vardata(dset,'spfh',values_3d) + do k = 1,nlevs + krecq = 1 + 3*nlevs + k + rwork_mem(:,krecq) = reshape(values_3d(:,:,k),(/npts/)) + end do + call read_vardata(dset,'o3mr',values_3d) + do k = 1,nlevs + krecoz = 1 + 4*nlevs + k + rwork_mem(:,krecoz) = reshape(values_3d(:,:,k),(/npts/)) + end do + call read_vardata(dset,'clwmr',values_3d) + do k = 1,nlevs + kreccwmr = 1 + 5*nlevs + k + rwork_mem(:,kreccwmr) = reshape(values_3d(:,:,k),(/npts/)) + end do + call read_vardata(dset,'icmr',values_3d) + do k = 1,nlevs + krecicmr = 1 + 6*nlevs + k + rwork_mem(:,krecicmr) = reshape(values_3d(:,:,k),(/npts/)) + end do + call close_dataset(dset) + deallocate(values_3d) endif call mpi_allreduce(rwork_mem,rwork_avg,nsize,mpi_real4,mpi_sum,new_comm,iret) @@ -263,7 +342,6 @@ program getsigensstatp if ( mype == 0 ) call write_to_disk('spread') - deallocate(rwork_mem,rwork_avg) ! Jump here if more mpi processors than files to process else @@ -271,6 +349,7 @@ program getsigensstatp endif call mpi_barrier(mpi_comm_world,iret) + deallocate(rwork_mem,rwork_avg) deallocate(new_group_members) if ( mype == 0 ) deallocate(glats) diff --git a/util/EnKF/gfs/src/recenterncio_hybgain.fd/CMakeLists.txt b/util/EnKF/gfs/src/recenterncio_hybgain.fd/CMakeLists.txt new file mode 100644 index 0000000000..22671e6ba1 --- /dev/null +++ b/util/EnKF/gfs/src/recenterncio_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(recenterncio_hybgain.x ${LOCAL_SRC} ) + set_target_properties( recenterncio_hybgain.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${NETCDF_INCLUDES} ${FV3GFS_NCIO_INCS}) + target_link_libraries( recenterncio_hybgain.x ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${FV3GFS_NCIO_LIBRARIES} ) +endif() diff --git a/util/EnKF/gfs/src/recenterncio_hybgain.fd/recenterncio_hybgain.f90 b/util/EnKF/gfs/src/recenterncio_hybgain.fd/recenterncio_hybgain.f90 new file mode 100644 index 0000000000..7f90c0eb89 --- /dev/null +++ b/util/EnKF/gfs/src/recenterncio_hybgain.fd/recenterncio_hybgain.f90 @@ -0,0 +1,240 @@ +program recenterncio_hybgain +!$$$ main program documentation block +! +! program: recenterncio_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 module_fv3gfs_ncio, only: open_dataset, create_dataset, read_attribute, & + Dataset, Dimension, close_dataset, has_attr, & + read_vardata, write_attribute, write_vardata, & + get_dim, quantize_data + + implicit none + + include "mpif.h" + + character*500 filename_fg,filename_varanal,filename_enkfanal,filenamein,& + filenameout,filename_anal,filename + character*3 charnanal + character(len=4) charnin + integer mype,mype1,npe,nanals,iret,ialpha,ibeta + integer:: nlats,nlons,nlevs,nvar,ndims,nbits + real alpha,beta + real(4),allocatable,dimension(:,:) :: values_2d_varanal,values_2d_enkfanal,values_2d_fg,values_2d_anal,& + values_2d_tmp, values_2d + real(4),allocatable,dimension(:,:,:) :: values_3d_varanal,values_3d_enkfanal,values_3d_fg,values_3d_anal,& + values_3d_tmp, values_3d + real(4) compress_err + type(Dataset) :: dseti,dseto,dset_anal,dset_fg,dset_varanal,dset_enkfanal + type(Dimension) :: londim,latdim,levdim + +! 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('RECENTERNCIO_HYBGAIN',2011,0319,0055,'NP25') + + call getarg(1,filename_fg) ! first guess ensmean background netcdf file + call getarg(2,filename_varanal) ! 3dvar analysis + call getarg(3,filename_enkfanal) ! 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 varanal (3dvar) + alpha = ialpha/1000. + call getarg(8,charnin) + read(charnin,'(i4)') ibeta ! wt for enkfanal (enkf) + beta = ibeta/1000. +! new_anal = fg + alpha*(varanal-fg) + beta(enkfanal-fg) +! = (1.-alpha-beta)*fg + alpha*varanal + beta*enkfanal +! how many ensemble members to process + call getarg(9,charnin) + read(charnin,'(i4)') nanals + + if (mype==0) then + write(6,*)'RECENTERNCIO_HYBGAIN: PROCESS ',nanals,' ENSEMBLE MEMBERS' + write(6,*)'ens mean background in ',trim(filename_fg) + write(6,*)'3dvar analysis in ',trim(filename_varanal) + write(6,*)'EnKF mean analysis in ',trim(filename_enkfanal) + 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 + dset_fg = open_dataset(filename_fg,errcode=iret) + if (iret == 0 ) then + if (mype == 0) write(6,*)'Read netcdf ',trim(filename_fg) + londim = get_dim(dset_fg,'grid_xt'); nlons = londim%len + latdim = get_dim(dset_fg,'grid_yt'); nlats = latdim%len + levdim = get_dim(dset_fg,'pfull'); nlevs = levdim%len + if (mype == 0) write(6,*)' nlons=',nlons,' nlats=',nlats,' nlevs=',nlevs + 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 + dset_varanal = open_dataset(filename_varanal,errcode=iret) + if (iret /= 0) then + print *,'error opening ',trim(filename_varanal) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + dset_enkfanal = open_dataset(filename_enkfanal,errcode=iret) + if (iret /= 0) then + print *,'error opening ',trim(filename_enkfanal) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + if (mype == 0) then + dset_anal = create_dataset(filename_anal, dset_enkfanal, & + copy_vardata=.true., errcode=iret) + if (iret /= 0) then + print *,'error opening ',trim(filename_anal) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + endif + write(charnanal,'(i3.3)') mype1 + filename = trim(filenamein)//"_mem"//charnanal + dseti = open_dataset(filename) + if (iret /= 0) then + print *,'error opening ',trim(filename) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + filename = trim(filenameout)//"_mem"//charnanal + dseto = create_dataset(filename, dset_enkfanal, copy_vardata=.true.,& + errcode=iret) + if (iret /= 0) then + print *,'error opening ',trim(filename) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + + do nvar=1,dset_fg%nvars + ndims = dset_fg%variables(nvar)%ndims + if (ndims > 2) then + if (ndims == 3 .and. trim(dset_fg%variables(nvar)%name) /= 'hgtsfc') then + ! pressfc + call read_vardata(dset_fg,trim(dset_fg%variables(nvar)%name),values_2d_fg) + call read_vardata(dset_varanal,trim(dset_fg%variables(nvar)%name),values_2d_varanal) + call read_vardata(dset_enkfanal,trim(dset_fg%variables(nvar)%name),values_2d_enkfanal) + call read_vardata(dseti,trim(dset_fg%variables(nvar)%name),values_2d) + ! blended analysis + values_2d_anal = (1.-alpha-beta)*values_2d_fg + & + alpha*values_2d_varanal + & + beta*values_2d_enkfanal + ! recentered ensemble member + values_2d = values_2d - values_2d_enkfanal + values_2d_anal + if (has_attr(dset_fg, 'nbits', trim(dset_fg%variables(nvar)%name))) then + call read_attribute(dset_fg, 'nbits', nbits, & + trim(dset_fg%variables(nvar)%name),errcode=iret) + else + iret = 1 + endif + if (mype == 0) then ! write out blended analysis on root task + if (iret == 0 .and. nbits > 0) then + values_2d_tmp = values_2d_anal + call quantize_data(values_2d_tmp, values_2d_anal, nbits, compress_err) + call write_attribute(dset_anal,& + 'max_abs_compression_error',compress_err,trim(dset_fg%variables(nvar)%name)) + endif + call write_vardata(dset_anal,trim(dset_fg%variables(nvar)%name),values_2d_anal) + endif + if (iret == 0 .and. nbits > 0) then + values_2d_tmp = values_2d + call quantize_data(values_2d_tmp, values_2d, nbits, compress_err) + call write_attribute(dseto,& + 'max_abs_compression_error',compress_err,trim(dset_fg%variables(nvar)%name)) + endif + call write_vardata(dseto,trim(dset_fg%variables(nvar)%name),values_2d) + else if (ndims == 4) then + call read_vardata(dset_fg,trim(dset_fg%variables(nvar)%name),values_3d_fg) + call read_vardata(dset_varanal,trim(dset_fg%variables(nvar)%name),values_3d_varanal) + call read_vardata(dset_enkfanal,trim(dset_fg%variables(nvar)%name),values_3d_enkfanal) + call read_vardata(dseti,trim(dset_fg%variables(nvar)%name),values_3d) + ! blended analysis + values_3d_anal = (1.-alpha-beta)*values_3d_fg + & + alpha*values_3d_varanal + & + beta*values_3d_enkfanal + ! recentered ensemble member + values_3d = values_3d - values_3d_enkfanal + values_3d_anal + if (has_attr(dset_fg, 'nbits', trim(dset_fg%variables(nvar)%name))) then + call read_attribute(dset_fg, 'nbits', nbits, & + trim(dset_fg%variables(nvar)%name),errcode=iret) + else + iret = 1 + endif + if (mype == 0) then ! write out blended analysis on root task + if (iret == 0 .and. nbits > 0) then + values_3d_tmp = values_3d_anal + call quantize_data(values_3d_tmp, values_3d_anal, nbits, compress_err) + call write_attribute(dset_anal,& + 'max_abs_compression_error',compress_err,trim(dset_fg%variables(nvar)%name)) + endif + call write_vardata(dset_anal,trim(dset_fg%variables(nvar)%name),values_3d_anal) + endif + if (iret == 0 .and. nbits > 0) then + values_3d_tmp = values_3d + call quantize_data(values_3d_tmp, values_3d, nbits, compress_err) + call write_attribute(dseto,& + 'max_abs_compression_error',compress_err,trim(dset_fg%variables(nvar)%name)) + endif + call write_vardata(dseto,trim(dset_fg%variables(nvar)%name),values_3d) + endif + endif ! ndims > 2 + enddo ! nvars + + + if (mype == 0) call close_dataset(dset_anal) + call close_dataset(dseti) + call close_dataset(dseto) + call close_dataset(dset_fg) + call close_dataset(dset_varanal) + call close_dataset(dset_enkfanal) + 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 recenterncio_hybgain diff --git a/util/EnKF/gfs/src/recentersigp.fd/CMakeLists.txt b/util/EnKF/gfs/src/recentersigp.fd/CMakeLists.txt index e6ff32d294..7a9d49192d 100644 --- a/util/EnKF/gfs/src/recentersigp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/recentersigp.fd/CMakeLists.txt @@ -5,6 +5,6 @@ if(BUILD_UTIL) 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} ) + include_directories( ${NEMSIOINC} ${SIGIOINC} ${NETCDF_INCLUDES} ${FV3GFS_NCIO_INCS}) + target_link_libraries( recentersigp.x ${SIGIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${FV3GFS_NCIO_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/recentersigp.fd/recentersigp.f90 b/util/EnKF/gfs/src/recentersigp.fd/recentersigp.f90 index c8eda79810..d3bdd33ba7 100644 --- a/util/EnKF/gfs/src/recentersigp.fd/recentersigp.f90 +++ b/util/EnKF/gfs/src/recentersigp.fd/recentersigp.f90 @@ -28,6 +28,10 @@ program recentersigp 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 + use module_fv3gfs_ncio, only: open_dataset, create_dataset, read_attribute, & + Dataset, Dimension, close_dataset, has_attr, has_var, & + read_vardata, write_attribute, write_vardata, & + get_dim, quantize_data implicit none @@ -37,19 +41,29 @@ program recentersigp TYPE(SIGIO_HEAD) :: SIGHEADI,SIGHEADO,SIGHEADMI,SIGHEADMO TYPE(SIGIO_DATA) :: SIGDATAI,SIGDATAO,SIGDATAMI,SIGDATAMO - logical:: nemsio, sigio - character*500 filename_meani,filename_meano,filenamein,filenameout + logical:: nemsio, sigio, ncio, increment, quantize + character*500 filename_meani,filename_meano,filenamein,filenameout,filename_meang character*3 charnanal character(len=4) charnin character(16),dimension(:),allocatable:: fieldname_di,fieldname_mi,fieldname_mo 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 + integer:: nrec,latb,lonb,levs,npts,n,i,nbits,nvar,ndims,j real,allocatable,dimension(:):: rwork1d real,allocatable,dimension(:,:) :: rwork1di,rwork1do,rwork1dmi,rwork1dmo + real(4),allocatable, dimension(:,:) :: values_2d, values_2d_i, values_2d_mi,& + values_2d_mo + real(4),allocatable, dimension(:,:,:) :: values_3d, values_3d_i, values_3d_mi,& + values_3d_mo, values_3d_mb, values_3d_anl + real(4) compress_err type(nemsio_gfile) :: gfilei, gfileo, gfilemi, gfilemo + type(Dataset) :: dseti,dseto,dsetmi,dsetmo,dsetmg + type(Dimension) :: londim,latdim,levdim + + namelist /recenter/ incvars_to_zero + character(len=12),dimension(10) :: incvars_to_zero !just picking 10 arbitrarily ! Initialize mpi call MPI_Init(ierr) @@ -79,6 +93,10 @@ program recentersigp call getarg(5,charnin) read(charnin,'(i4)') nanals +! option for increment, read in ens mean guess + call getarg(6,filename_meang) + + if (mype==0) then write(6,*)'RECENTERSIGP: PROCESS ',nanals,' ENSEMBLE MEMBERS' write(6,*)'filenamein=',trim(filenamein) @@ -89,28 +107,47 @@ program recentersigp sigio=.false. nemsio=.false. + ncio=.false. + increment=.false. mype1 = mype+1 if (mype1 <= nanals) then - call nemsio_init(iret=iret) - call sigio_srohdc(nsigi,trim(filename_meani), & - sigheadmi,sigdatami,iret) - if (iret == 0 ) then - sigio = .true. - write(6,*)'Read sigio ',trim(filename_meani),' iret=',iret - else - call nemsio_open(gfilemi,trim(filename_meani),'READ',iret=iret) + + dsetmi = open_dataset(filename_meani,errcode=iret) + if (iret == 0) then +! this is a netCDF file but now we need to determine +! if it is a netCDF analysis or increment +! going to assume all increment files will have temperature increments + if (has_var(dsetmi,'T_inc')) then + increment = .true. + else + ncio = .true. + end if + endif + + if (.not. ncio .and. .not. increment) then + call sigio_srohdc(nsigi,trim(filename_meani), & + sigheadmi,sigdatami,iret) if (iret == 0 ) then - nemsio = .true. - write(6,*)'Read nemsio ',trim(filename_meani),' iret=',iret - call nemsio_getfilehead(gfilemi, nrec=nrec, dimx=lonb, dimy=latb, dimz=levs, iret=iret) - write(6,*)' lonb=',lonb,' latb=',latb,' levs=',levs,' nrec=',nrec + sigio = .true. + write(6,*)'Read sigio ',trim(filename_meani),' iret=',iret else - write(6,*)'***ERROR*** ',trim(filenamein),' contains unrecognized format. ABORT' + call nemsio_init(iret=iret) + call nemsio_open(gfilemi,trim(filename_meani),'READ',iret=iret) + if (iret == 0 ) then + nemsio = .true. + write(6,*)'Read nemsio ',trim(filename_meani),' iret=',iret + call nemsio_getfilehead(gfilemi, nrec=nrec, dimx=lonb, dimy=latb, dimz=levs, iret=iret) + write(6,*)' lonb=',lonb,' latb=',latb,' levs=',levs,' nrec=',nrec + else + write(6,*)'***ERROR*** ',trim(filenamein)//"_mem"//charnanal,' contains unrecognized format. ABORT' + endif endif endif - if (.not.nemsio .and. .not.sigio) goto 100 - if (mype==0) write(6,*)'processing files with nemsio=',nemsio,' sigio=',sigio + + if (.not.nemsio .and. .not.sigio .and. .not.ncio .and. .not. increment ) goto 100 + + if (mype==0) write(6,*)'processing files with nemsio=',nemsio,' sigio=',sigio,' ncio=',ncio,' increment=',increment if (sigio) then @@ -198,6 +235,140 @@ program recentersigp call nemsio_close(gfileo,iret=iret) write(6,*)'task mype=',mype,' process ',trim(filenameout)//"_mem"//charnanal,' iret=',iret + else if (increment) then + + ! read in namelist for incvars_to_zero + incvars_to_zero(:) = 'NONE' + open(912,file='recenter.nml',form="formatted") + read(912,recenter) + close(912) + + if (mype == 0) write(6,*) 'Read netcdf increment' + londim = get_dim(dsetmi,'lon'); lonb = londim%len + latdim = get_dim(dsetmi,'lat'); latb = latdim%len + levdim = get_dim(dsetmi,'lev'); levs = levdim%len + write(charnanal,'(i3.3)') mype1 + dsetmo = open_dataset(filename_meano) + dsetmg = open_dataset(filename_meang) + dseti = open_dataset(trim(filenamein)//"_mem"//charnanal) + dseto = create_dataset(trim(filenameout)//"_mem"//charnanal, dseti, copy_vardata=.true.) + allocate(values_3d(lonb,latb,levs)) + do nvar=1,dseti%nvars + ndims = dseti%variables(nvar)%ndims + if (ndims == 3) then ! only 3D fields need to be processed + call read_vardata(dseti,trim(dseti%variables(nvar)%name),values_3d_i) + call read_vardata(dsetmi,trim(dseti%variables(nvar)%name),values_3d_mi) + ! need to do select case since ges/anl and increment have different varnames + select case (dseti%variables(nvar)%name) + case ('u_inc') + call read_vardata(dsetmg,'ugrd',values_3d_mb) + call read_vardata(dsetmo,'ugrd',values_3d_anl) + case ('v_inc') + call read_vardata(dsetmg,'vgrd',values_3d_mb) + call read_vardata(dsetmo,'vgrd',values_3d_anl) + case ('delp_inc') + call read_vardata(dsetmg,'dpres',values_3d_mb) + call read_vardata(dsetmo,'dpres',values_3d_anl) + case ('delz_inc') + call read_vardata(dsetmg,'delz',values_3d_mb) + call read_vardata(dsetmo,'delz',values_3d_anl) + case ('T_inc') + call read_vardata(dsetmg,'tmp',values_3d_mb) + call read_vardata(dsetmo,'tmp',values_3d_anl) + case ('sphum_inc') + call read_vardata(dsetmg,'spfh',values_3d_mb) + call read_vardata(dsetmo,'spfh',values_3d_anl) + case ('liq_wat_inc') + call read_vardata(dsetmg,'clwmr',values_3d_mb) + call read_vardata(dsetmo,'clwmr',values_3d_anl) + case ('o3mr_inc') + call read_vardata(dsetmg,'o3mr',values_3d_mb) + call read_vardata(dsetmo,'o3mr',values_3d_anl) + case ('icmr_inc') + call read_vardata(dsetmg,'icmr',values_3d_mb) + call read_vardata(dsetmo,'icmr',values_3d_anl) + end select + values_3d(:,:,:) = zero + do j=1,latb + values_3d(:,j,:) = values_3d_i(:,j,:) - values_3d_mb(:,latb-j+1,:) - values_3d_mi(:,j,:) + values_3d_anl(:,latb-j+1,:) + end do + if (should_zero_increments_for(trim(dseti%variables(nvar)%name))) values_3d = zero + call write_vardata(dseto,trim(dseti%variables(nvar)%name),values_3d) + end if + end do + deallocate(values_3d,values_3d_i,values_3d_mi,values_3d_mb,values_3d_anl) + call write_attribute(dseto,'comment','recentered analysis increment using recentersigp') + call close_dataset(dsetmi) + call close_dataset(dsetmo) + call close_dataset(dsetmg) + call close_dataset(dseti) + call close_dataset(dseto) + + else if (ncio) then + + if (mype == 0) write(6,*) 'Read netcdf' + londim = get_dim(dsetmi,'grid_xt'); lonb = londim%len + latdim = get_dim(dsetmi,'grid_yt'); latb = latdim%len + levdim = get_dim(dsetmi,'pfull'); levs = levdim%len + write(charnanal,'(i3.3)') mype1 + dsetmo = open_dataset(filename_meano) + dseti = open_dataset(trim(filenamein)//"_mem"//charnanal) + dseto = create_dataset(trim(filenameout)//"_mem"//charnanal, dseti, copy_vardata=.true.) + do nvar=1,dseti%nvars + ndims = dseti%variables(nvar)%ndims + if (ndims > 2) then + if (ndims == 3 .and. trim(dseti%variables(nvar)%name) /= 'hgtsfc') then + ! pressfc + call read_vardata(dseti,trim(dseti%variables(nvar)%name),values_2d_i) + call read_vardata(dsetmi,trim(dseti%variables(nvar)%name),values_2d_mi) + call read_vardata(dsetmo,trim(dseti%variables(nvar)%name),values_2d_mo) + values_2d = values_2d_i - values_2d_mi + values_2d_mo + if (has_attr(dseti, 'nbits', trim(dseti%variables(nvar)%name))) then + call read_attribute(dseti, 'nbits', nbits, & + trim(dseti%variables(nvar)%name)) + quantize = .true. + if (nbits < 1) quantize = .false. + else + quantize = .false. + endif + if (quantize) then + values_2d_mi = values_2d + call quantize_data(values_2d_mi, values_2d, nbits, compress_err) + call write_attribute(dseto,& + 'max_abs_compression_error',compress_err,trim(dseti%variables(nvar)%name)) + endif + call write_vardata(dseto,trim(dseti%variables(nvar)%name),values_2d) + else if (ndims == 4) then + call read_vardata(dseti,trim(dseti%variables(nvar)%name),values_3d_i) + call read_vardata(dsetmi,trim(dseti%variables(nvar)%name),values_3d_mi) + call read_vardata(dsetmo,trim(dseti%variables(nvar)%name),values_3d_mo) + values_3d = values_3d_i - values_3d_mi + values_3d_mo + if (has_attr(dseti, 'nbits', trim(dseti%variables(nvar)%name))) then + call read_attribute(dseti, 'nbits', nbits, & + trim(dseti%variables(nvar)%name)) + quantize = .true. + if (nbits < 1) quantize = .false. + else + quantize = .false. + endif + if (quantize) then + values_3d_mi = values_3d + call quantize_data(values_3d_mi, values_3d, nbits, compress_err) + call write_attribute(dseto,& + 'max_abs_compression_error',compress_err,trim(dseti%variables(nvar)%name)) + endif + call write_vardata(dseto,trim(dseti%variables(nvar)%name),values_3d) + endif + endif ! ndims > 2 + enddo ! nvars + + deallocate(values_2d,values_2d_i,values_2d_mi,values_2d_mo) + deallocate(values_3d,values_3d_i,values_3d_mi,values_3d_mo) + call close_dataset(dsetmi) + call close_dataset(dsetmo) + call close_dataset(dseti) + call close_dataset(dseto) + endif ! Jump here if more mpi processors than files to process @@ -208,7 +379,7 @@ program recentersigp 100 continue call MPI_Barrier(MPI_COMM_WORLD,ierr) - if (mype1 <= nanals .and. .not.nemsio .and. .not.sigio) then + if (mype1 <= nanals .and. .not.nemsio .and. .not.sigio .and. .not. ncio .and. .not. increment) then call MPI_Abort(MPI_COMM_WORLD,98,iret) stop endif @@ -220,6 +391,30 @@ program recentersigp print *, 'MPI_Finalize error status = ',ierr end if +contains + + !! 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=12) :: varname ! temporary string for storing variable names + integer :: i ! incvars_to_zero loop index + + should_zero_increments_for=.false. + + zeros_loop: do i=1,size(incvars_to_zero) + 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 + END program recentersigp subroutine getorder(flnm1,flnm2,fllevtyp1,fllevtyp2,fllev1,fllev2,nrec,order) diff --git a/util/Ozone_Monitor/image_gen/ush/mk_summary.sh b/util/Ozone_Monitor/image_gen/ush/mk_summary.sh index c400504d0e..823205cf05 100755 --- a/util/Ozone_Monitor/image_gen/ush/mk_summary.sh +++ b/util/Ozone_Monitor/image_gen/ush/mk_summary.sh @@ -52,7 +52,22 @@ for ptype in ${process_type}; do ctr=0 >$cmdfile for type in ${SATYPE}; do - if [[ $type != "omi_aura" && $type != "gome_metop-a" && $type != "gome_metop-b" ]]; then + + #-------------------------------------------------------------------- + # Note: This if statement is a a bandaide. The better solution is + # to poll the ctl file for the source, extract the number of + # levels, and only include those instruments where nlev > 1. + # Alternately that information could be added to the satype + # table, or use the GFS obstype table maybe. Either way I + # need to fix this fast and engineer a better solution after + # some consideration, so it's bandaide now, and elegant + # solution in the next release. + # + # Summary plots are dimensioned on the x axis by number of + # levels, so when nlev = 1 the plot script doesn't work. + # + if [[ $type != "omi_aura" && $type != "gome_metop-a" && \ + $type != "gome_metop-b" && $type != "ompstc8_npp" ]]; then if [[ ${MY_MACHINE} = "hera" ]]; then echo "${ctr} ${OZN_IG_SCRIPTS}/plot_summary.sh $type $ptype" >> $cmdfile else 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 42951f3269..529ece776b 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 ompslp_npp ompsnp_npp ompstc8_npp +gome_metop-a gome_metop-b omi_aura sbuv2_n19 ompsnp_npp ompstc8_npp 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 index d7d502a48e..fd434a4da2 100644 --- 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 @@ -7,7 +7,7 @@ cmake_minimum_required(VERSION 2.6) 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} ) + target_link_libraries( oznmon_horiz.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_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/read_diag.f90 b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/read_diag.f90 index bc8b4d6df8..7e592d3a5e 100644 --- a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/read_diag.f90 +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/read_diag.f90 @@ -340,9 +340,8 @@ subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istat integer(i_kind),dimension(:),allocatable :: iouse real(r_double),dimension(:),allocatable :: pobs,gross,tnoise - integer(i_kind) :: nsdim,k,idate + integer(i_kind) :: nsdim,k,idate,idx integer(i_kind),dimension(:),allocatable :: iuse_flag - integer(i_kind) :: analysis_use_flag,idx istatus = 0 @@ -406,10 +405,9 @@ subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istat !------------------------------------------------------------------- ! 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). - + ! location. Assign the first nlevs number of those values to + ! the iuse_flag array. + ! idx = find_ncdiag_id(ftin) if( verify_var_name_nc( "Analysis_Use_Flag" ) ) then @@ -417,11 +415,12 @@ subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istat 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 + do k=1,ncdiag_open_status(idx)%num_records + iuse_flag(k) = -1 + end do + end if else write(6,*) 'WARNING: unable to read global var Analysis_Use_Flag from file ' @@ -453,10 +452,10 @@ subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istat 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 - + header_nlev(k)%iouse = iuse_flag(k) end do - deallocate( pobs,gross,tnoise ) + + deallocate( pobs,gross,tnoise,iuse_flag ) end subroutine read_ozndiag_header_nc @@ -610,6 +609,10 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext integer(i_kind) ,intent(out) :: ntobs integer(i_kind) :: id,ii,jj,cur_idx integer(i_kind),allocatable :: Use_Flag(:) + integer(i_kind) :: nlevs ! number of levels + integer(i_kind) :: nrecords ! number of file records, which + ! is number of levels * number of obs + real(r_single),allocatable :: lat(:) ! latitude (deg) real(r_single),allocatable :: lon(:) ! longitude (deg) @@ -621,7 +624,7 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext 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 ) @@ -643,7 +646,8 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext ! 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. - + + nlevs = header_fix%nlevs if( ncdiag_open_status(cur_idx)%nc_read == .true. ) then iflag = -1 @@ -652,7 +656,14 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext ntobs = 0 id = find_ncdiag_id(ftin) - ntobs = ncdiag_open_status(id)%num_records + nrecords = ncdiag_open_status(id)%num_records + if( header_fix%nlevs > 1 ) then + ntobs = nrecords / header_fix%nlevs + else + ntobs = nrecords + end if + + write(6,*) 'header_fix%nlevs, ncdiag_open_status(id)%num_records, ntobs = ', header_fix%nlevs, ncdiag_open_status(id)%num_records, ntobs !------------------------------------ ! allocate the returned structures @@ -664,9 +675,9 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext !--------------------------------- ! load data_fix structure ! - allocate( lat(ntobs) ) - allocate( lon(ntobs) ) - allocate( obstime(ntobs) ) + allocate( lat(nrecords) ) + allocate( lon(nrecords) ) + allocate( obstime(nrecords) ) !--- get obs data ! @@ -694,10 +705,14 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext write(6,*) 'WARNING: unable to read global var Time from file ' end if + !----------------------------------------------- + ! lat, lon, obstime are dimensioned to nrecords + ! read those as nobs * nlevs + ! do ii=1,ntobs - data_fix(ii)%lat = lat(ii) - data_fix(ii)%lon = lon(ii) - data_fix(ii)%obstime = obstime(ii) + data_fix(ii)%lat = lat(ii + ((ii-1)*nlevs) ) + data_fix(ii)%lon = lon(ii + ((ii-1)*nlevs) ) + data_fix(ii)%obstime = obstime(ii + ((ii-1)*nlevs) ) end do deallocate( lat, lon, obstime ) @@ -705,13 +720,13 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext !--------------------------------- ! 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) ) + allocate( data_nlev( header_fix%nlevs,nrecords ) ) + allocate( ozobs(nrecords) ) + allocate( ozone_inv(nrecords) ) + allocate( varinv(nrecords) ) + allocate( sza(nrecords) ) + allocate( fovn(nrecords) ) + allocate( toqf(nrecords) ) if( verify_var_name_nc( "Observation" ) ) then call nc_diag_read_get_var( ftin, 'Observation', ozobs ) @@ -749,14 +764,19 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext write(6,*) 'WARNING: unable to read var Row_Anomaly_Index from file ' end if - do jj=1,ntobs + + !------------------------------------------------ + ! All vars used to read the file are dimensioned + ! to nrecord, which is nobs * nlevs + ! + do jj=0,ntobs-1 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 ) + data_nlev(ii,jj)%ozobs = ozobs( ii + (jj * nlevs) ) + data_nlev(ii,jj)%ozone_inv = ozone_inv( ii + (jj * nlevs) ) + data_nlev(ii,jj)%varinv = varinv( ii + (jj * nlevs) ) + data_nlev(ii,jj)%sza = sza( ii + (jj * nlevs) ) + data_nlev(ii,jj)%fovn = fovn( ii + (jj * nlevs) ) + data_nlev(ii,jj)%toqf = toqf( ii + (jj * nlevs) ) end do end do 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 index b9f0fa1bd7..5a6c15b41a 100644 --- 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 @@ -7,7 +7,7 @@ cmake_minimum_required(VERSION 2.6) 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} ) + target_link_libraries( oznmon_time.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_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/read_diag.f90 b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/read_diag.f90 index bc8b4d6df8..7e592d3a5e 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 @@ -340,9 +340,8 @@ subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istat integer(i_kind),dimension(:),allocatable :: iouse real(r_double),dimension(:),allocatable :: pobs,gross,tnoise - integer(i_kind) :: nsdim,k,idate + integer(i_kind) :: nsdim,k,idate,idx integer(i_kind),dimension(:),allocatable :: iuse_flag - integer(i_kind) :: analysis_use_flag,idx istatus = 0 @@ -406,10 +405,9 @@ subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istat !------------------------------------------------------------------- ! 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). - + ! location. Assign the first nlevs number of those values to + ! the iuse_flag array. + ! idx = find_ncdiag_id(ftin) if( verify_var_name_nc( "Analysis_Use_Flag" ) ) then @@ -417,11 +415,12 @@ subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istat 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 + do k=1,ncdiag_open_status(idx)%num_records + iuse_flag(k) = -1 + end do + end if else write(6,*) 'WARNING: unable to read global var Analysis_Use_Flag from file ' @@ -453,10 +452,10 @@ subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istat 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 - + header_nlev(k)%iouse = iuse_flag(k) end do - deallocate( pobs,gross,tnoise ) + + deallocate( pobs,gross,tnoise,iuse_flag ) end subroutine read_ozndiag_header_nc @@ -610,6 +609,10 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext integer(i_kind) ,intent(out) :: ntobs integer(i_kind) :: id,ii,jj,cur_idx integer(i_kind),allocatable :: Use_Flag(:) + integer(i_kind) :: nlevs ! number of levels + integer(i_kind) :: nrecords ! number of file records, which + ! is number of levels * number of obs + real(r_single),allocatable :: lat(:) ! latitude (deg) real(r_single),allocatable :: lon(:) ! longitude (deg) @@ -621,7 +624,7 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext 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 ) @@ -643,7 +646,8 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext ! 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. - + + nlevs = header_fix%nlevs if( ncdiag_open_status(cur_idx)%nc_read == .true. ) then iflag = -1 @@ -652,7 +656,14 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext ntobs = 0 id = find_ncdiag_id(ftin) - ntobs = ncdiag_open_status(id)%num_records + nrecords = ncdiag_open_status(id)%num_records + if( header_fix%nlevs > 1 ) then + ntobs = nrecords / header_fix%nlevs + else + ntobs = nrecords + end if + + write(6,*) 'header_fix%nlevs, ncdiag_open_status(id)%num_records, ntobs = ', header_fix%nlevs, ncdiag_open_status(id)%num_records, ntobs !------------------------------------ ! allocate the returned structures @@ -664,9 +675,9 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext !--------------------------------- ! load data_fix structure ! - allocate( lat(ntobs) ) - allocate( lon(ntobs) ) - allocate( obstime(ntobs) ) + allocate( lat(nrecords) ) + allocate( lon(nrecords) ) + allocate( obstime(nrecords) ) !--- get obs data ! @@ -694,10 +705,14 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext write(6,*) 'WARNING: unable to read global var Time from file ' end if + !----------------------------------------------- + ! lat, lon, obstime are dimensioned to nrecords + ! read those as nobs * nlevs + ! do ii=1,ntobs - data_fix(ii)%lat = lat(ii) - data_fix(ii)%lon = lon(ii) - data_fix(ii)%obstime = obstime(ii) + data_fix(ii)%lat = lat(ii + ((ii-1)*nlevs) ) + data_fix(ii)%lon = lon(ii + ((ii-1)*nlevs) ) + data_fix(ii)%obstime = obstime(ii + ((ii-1)*nlevs) ) end do deallocate( lat, lon, obstime ) @@ -705,13 +720,13 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext !--------------------------------- ! 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) ) + allocate( data_nlev( header_fix%nlevs,nrecords ) ) + allocate( ozobs(nrecords) ) + allocate( ozone_inv(nrecords) ) + allocate( varinv(nrecords) ) + allocate( sza(nrecords) ) + allocate( fovn(nrecords) ) + allocate( toqf(nrecords) ) if( verify_var_name_nc( "Observation" ) ) then call nc_diag_read_get_var( ftin, 'Observation', ozobs ) @@ -749,14 +764,19 @@ subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_ext write(6,*) 'WARNING: unable to read var Row_Anomaly_Index from file ' end if - do jj=1,ntobs + + !------------------------------------------------ + ! All vars used to read the file are dimensioned + ! to nrecord, which is nobs * nlevs + ! + do jj=0,ntobs-1 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 ) + data_nlev(ii,jj)%ozobs = ozobs( ii + (jj * nlevs) ) + data_nlev(ii,jj)%ozone_inv = ozone_inv( ii + (jj * nlevs) ) + data_nlev(ii,jj)%varinv = varinv( ii + (jj * nlevs) ) + data_nlev(ii,jj)%sza = sza( ii + (jj * nlevs) ) + data_nlev(ii,jj)%fovn = fovn( ii + (jj * nlevs) ) + data_nlev(ii,jj)%toqf = toqf( ii + (jj * nlevs) ) end do end do 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 cb90f48fa0..d6402196aa 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 @@ -235,37 +235,40 @@ program main do j = 1, n_levs - !------------------------------------------------------------------ - ! Accumulate sums in appropriate regions. - ! This is done for all obs, assimilated or not. - ! Earlier versions of this code included a commented out line - ! which contained a check for assimlated status: - ! - ! if (data_nlev(j,iobs)%varinv > 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) + if (data_nlev(1,iobs)%varinv > 1.e-6) then + + !------------------------------------------------------------------ + ! Accumulate sums in appropriate regions. + ! This is done for all obs, assimilated or not. + ! Earlier versions of this code included a commented out line + ! which contained a check for assimlated status: + ! + ! if (data_nlev(j,iobs)%varinv > 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-assimilated 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 - end do - + end if enddo else ! mls data sources @@ -330,6 +333,7 @@ program main if( validate == .TRUE. ) then call load_base( satname, ier ) + write(6,*) 'ier from load_base = ', ier open(lupen,file=bad_pen_file,form='formatted') open(lucnt,file=bad_cnt_file,form='formatted') @@ -341,7 +345,7 @@ program main do j=1,n_levs if ( use(j,k) > 0.0 ) then - if( validate == .TRUE. ) then + if( validate == .TRUE. .AND. ier >= 0 ) then pbound = 0.00 call validate_penalty( j, k, penalty(j,k), valid_penalty, pbound, iret ) 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 index a98f2ce982..bbc953c74e 100755 --- 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 @@ -69,6 +69,8 @@ subroutine load_base( satname, iret ) logical fexist + write(6,*) '--> load_base, satname = ', satname + !--- initialization iret = -1 fname = trim(satname) // '.base' @@ -126,10 +128,14 @@ subroutine load_base( satname, iret ) iret = 0 base_loaded = .TRUE. else - write(*,*) 'WARNING: unable to load fname for data error checking' + write(*,*) 'WARNING: unable to load ', fname, ' for data error checking' + base_loaded = .FALSE. end if + write(6,*) '<-- load_base, base_loaded = ', base_loaded + + end subroutine load_base @@ -235,10 +241,10 @@ subroutine validate_penalty( level, region, penalty, valid, bound, iret ) valid = .FALSE. bound = rmiss - if( base_loaded .eqv. .TRUE. .AND. nlevel > 1 ) then + 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 + write(*,*) 'Warning: In validate_penalty attempt to validate level out of range', level, nlevel valid = .TRUE. else if( region < 1 .OR. region > nregion ) then iret = -2 diff --git a/util/Radiance_Monitor/CMakeLists.txt b/util/Radiance_Monitor/CMakeLists.txt index 6a9cf33534..b45f577b90 100644 --- a/util/Radiance_Monitor/CMakeLists.txt +++ b/util/Radiance_Monitor/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 2.6) +cmake_minimum_required(VERSION 2.8) if(CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) # I am top-level project. if( NOT DEFINED ENV{CC} ) @@ -32,8 +32,8 @@ if(CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) endif() project(COV_Calc) enable_language (Fortran) - find_package(OpenMP) set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/../../cmake/Modules/") + set(CMAKE_LIBRARY_OUTPUT_DIRECTORY "${PROJECT_BINARY_DIR}/lib") include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setPlatformVariables.cmake) include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setIntelFlags.cmake) include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setGNUFlags.cmake) @@ -64,20 +64,40 @@ if(CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) message("Setting PGI flags") setPGI() endif() + + cmake_policy(SET CMP0009 NEW) + 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() + 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(FIND_HDF5_HL) - find_package(HDF5 COMPONENTS C HL Fortran_HL ) - elseif(FIND_HDF5) - find_package(HDF5) + if(NETCDF4) + if(CMAKE_MAJOR_VERSION GREATER 2) + find_package( ZLIB ) + endif() + find_package( CURL ) endif() + find_package( W3NCO ) - set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag") + set(BUILD_NCDIAG ON) + set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag") 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) diff --git a/util/Radiance_Monitor/image_gen/src/radmon_ig_horiz.fd/CMakeLists.txt b/util/Radiance_Monitor/image_gen/src/radmon_ig_horiz.fd/CMakeLists.txt index 843cc1391a..2efb30847b 100644 --- a/util/Radiance_Monitor/image_gen/src/radmon_ig_horiz.fd/CMakeLists.txt +++ b/util/Radiance_Monitor/image_gen/src/radmon_ig_horiz.fd/CMakeLists.txt @@ -7,7 +7,7 @@ cmake_minimum_required(VERSION 2.6) set_target_properties( radmon_ig_horiz.x PROPERTIES COMPILE_FLAGS ${RADMON_HORIZ_Fortran_FLAGS} ) set_target_properties( radmon_ig_horiz.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) include_directories( ${CORE_INCS} ${NCDIAG_INCS} ) - target_link_libraries( radmon_ig_horiz.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ) + target_link_libraries( radmon_ig_horiz.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${MPI_Fortran_LIBRARIES}) if(BUILD_W3NCO) add_dependencies( radmon_ig_horiz.x ${W3NCO_4_LIBRARY} ) endif() diff --git a/util/Radiance_Monitor/image_gen/ush/run_plot_v16rt0.sh b/util/Radiance_Monitor/image_gen/ush/run_plot_v16rt0.sh deleted file mode 100755 index 554132a6cd..0000000000 --- a/util/Radiance_Monitor/image_gen/ush/run_plot_v16rt0.sh +++ /dev/null @@ -1,56 +0,0 @@ -#!/bin/sh - -module load ips/18.0.1.163 -module load metplus/2.1 -module load prod_util/1.1.2 - -package=ProdGSI/util/Radiance_Monitor -suffix=v16rt0 -export RUN=gdas - -idev=`cat /etc/dev | cut -c1` -iprod=`cat /etc/prod | cut -c1` - -scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/RadMon/image_gen/ush - -export USE_STATIC_SATYPE=1 -export DO_DATA_RPT=1 -export DO_DIAG_RPT=1 -#export NDATE=/nwprod/util/exec/ndate -#export DO_ARCHIVE=1 -export JOB_QUEUE=dev_shared -export NUM_CYCLES=360 -#export MAIL_CC="russ.treadon@noaa.gov, andrew.collard@noaa.gov" -#export MAIL_CC="edward.c.safford@gmail.com" -export MAIL_TO="edward.safford@noaa.gov" - -export REGIONAL_RR=0 -export CYCLE_INTERVAL=6 -export TANK_USE_RUN=1 -export RUN_TRANSFER=0 - -data_map=${scripts}/data_map.xml - -TANKverf=/u/Edward.Safford/nbns/stats/${suffix} - -#imgdate=`${scripts}/query_data_map.pl ${data_map} ${suffix} imgdate` -#idate=`$NDATE +${CYCLE_INTERVAL} $imgdate` -idate=2018123118 - -prodate=`${scripts}/nu_find_cycle.pl --cyc 1 --dir ${TANKverf} --run ${RUN}` -echo "imgdate, prodate = $imgdate, $prodate" - -logdir="/gpfs/dell2/ptmp/Edward.Safford/logs/${suffix}/${RUN}/radmon" -if [[ $idate -le $prodate ]]; then - - echo " firing CkPlt_glbl.sh" - ${scripts}/CkPlt_glbl.sh $suffix $idate \ - 1>${logdir}/CkPlt_${suffix}.log \ - 2>${logdir}/CkPlt_${suffix}.err - -# rc=`${scripts}/update_data_map.pl ${data_map} ${suffix} imgdate ${idate}` - -fi - - -exit diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh index f18fc1818c..97d841806e 100755 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh +++ b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh @@ -8,13 +8,13 @@ #BSUB -R affinity[core] #BSUB -M 5000 #BSUB -W 00:20 -#BSUB -P GFS-T2O +#BSUB -P GFS-DEV set -x #export PDATE=2018091706 # binary radstat #export PDATE=2018110206 # netcdf radstat -export PDATE=2019062900 # netcdf radstat +export PDATE=2020022806 # netcdf radstat ############################################################# # Specify whether the run is production or development @@ -24,16 +24,16 @@ export cyc=`echo $PDATE | cut -c9-10` export job=gdas_verfrad.${cyc} export pid=${pid:-$$} export jobid=${job}.${pid} -export envir=para +export envir=prod #export DATAROOT=/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/test_data -export DATAROOT=/gpfs/dell3/ptmp/emc.glopara/ROTDIRS/v16rt0 -export COMROOT=/gpfs/dell2/ptmp/$LOGNAME/com +#export DATAROOT=/gpfs/dell3/ptmp/emc.glopara/ROTDIRS/v16rt0 +export DATAROOT=/gpfs/dell1/nco/ops/com/gfs/prod +export COMROOT=/gpfs/dell2/ptmp/${LOGNAME} if [[ ! -d ${COMROOT}/logs/jlogfiles ]]; then mkdir -p ${COMROOT}/logs/jlogfiles fi - ############################################################# # Specify versions ############################################################# @@ -67,8 +67,13 @@ export POE=YES ############################################################# # Set user specific variables ############################################################# -export RADMON_SUFFIX=run2netcdf +export RADMON_SUFFIX=test_rad export DATA=/gpfs/dell2/stmp/Edward.Safford/${RADMON_SUFFIX} # rename this to WORKDIR +if [[ -d ${DATA} ]]; then + rm -rf ${DATA} + mkdir -p ${DATA} +fi +export jlogfile=${COMROOT}/logs/jlogfiles/${RADMON_SUFFIX}_jlog export NWTEST=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor/nwprod diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_satype.txt b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_satype.txt index ec2e4a208e..fd3b23aa55 100644 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_satype.txt +++ b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_satype.txt @@ -1 +1,2 @@ -airs_aqua amsua_aqua amsua_metop-a amsua_metop-b amsua_n15 amsua_n18 amsua_n19 hirs4_metop-a hirs4_metop-b hirs4_n19 iasi_metop-a iasi_metop-b mhs_metop-a mhs_metop-b mhs_n18 mhs_n19 atms_npp cris-fsr_npp seviri_m08 seviri_m10 seviri_m11 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 ssmis_f17 ssmis_f18 avhrr_metop-a avhrr_n18 saphir_meghat atms_n20 cris-fsr_n20 abi_g16 ahi_himawari8 +abi_g16 abi_g17 ahi_himawari8 airs_aqua amsua_aqua amsua_metop-a amsua_metop-b amsua_metop-c amsua_n15 amsua_n18 amsua_n19 atms_npp atms_n20 avhrr_metop-a avhrr_metop-b avhrr_n18 avhrr_n19 cris-fsr_npp cris-fsr_n20 hirs4_metop-a hirs4_metop-b hirs4_n19 iasi_metop-a iasi_metop-b mhs_metop-a mhs_metop-b mhs_metop-c mhs_n19 saphir_meghat seviri_m08 seviri_m11 ssmis_f17 ssmis_f18 + diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_scaninfo.txt b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_scaninfo.txt index 25e7702bc1..ecb51f7b6d 100644 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_scaninfo.txt +++ b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_scaninfo.txt @@ -59,4 +59,5 @@ saphir_meghat -42.960 0.666 130 abi_g16 0.00 1.00 90 ahi_himawari8 0.00 1.00 90 + abi_g17 0.00 1.00 90 !sat_sis start step nstep diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radang.fd/CMakeLists.txt b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radang.fd/CMakeLists.txt index fad4acfe22..b60da32a7d 100644 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radang.fd/CMakeLists.txt +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radang.fd/CMakeLists.txt @@ -7,7 +7,7 @@ cmake_minimum_required(VERSION 2.6) set_target_properties( radmon_angle.x PROPERTIES COMPILE_FLAGS ${RADMON_ANGLE_Fortran_FLAGS} ) set_target_properties( radmon_angle.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) include_directories( ${CORE_INCS} ${NCDIAG_INCS} ) - target_link_libraries( radmon_angle.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ) + target_link_libraries( radmon_angle.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) if(BUILD_W3NCO) add_dependencies( radmon_angle.x ${W3NCO_4_LIBRARY} ) endif() diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcoef.fd/CMakeLists.txt b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcoef.fd/CMakeLists.txt index d6a8051220..4a94749272 100644 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcoef.fd/CMakeLists.txt +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcoef.fd/CMakeLists.txt @@ -7,7 +7,7 @@ cmake_minimum_required(VERSION 2.6) set_target_properties( radmon_bcoef.x PROPERTIES COMPILE_FLAGS ${RADMON_BCOEF_Fortran_FLAGS} ) set_target_properties( radmon_bcoef.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) include_directories( ${CORE_INCS} ${NCDIAG_INCS} ) - target_link_libraries( radmon_bcoef.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ) + target_link_libraries( radmon_bcoef.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) if(BUILD_W3NCO) add_dependencies( radmon_bcoef.x ${W3NCO_4_LIBRARY} ) endif() diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcor.fd/CMakeLists.txt b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcor.fd/CMakeLists.txt index a51728cfbd..607d841e09 100644 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcor.fd/CMakeLists.txt +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcor.fd/CMakeLists.txt @@ -7,7 +7,7 @@ cmake_minimum_required(VERSION 2.6) set_target_properties( radmon_bcor.x PROPERTIES COMPILE_FLAGS ${RADMON_BCOR_Fortran_FLAGS} ) set_target_properties( radmon_bcor.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) include_directories( ${CORE_INCS} ${NCDIAG_INCS} ) - target_link_libraries( radmon_bcor.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ) + target_link_libraries( radmon_bcor.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) if(BUILD_W3NCO) add_dependencies( radmon_bcor.x ${W3NCO_4_LIBRARY} ) endif() diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/CMakeLists.txt b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/CMakeLists.txt index cd2c1a089a..8c59a6349b 100644 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/CMakeLists.txt +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/CMakeLists.txt @@ -7,7 +7,7 @@ cmake_minimum_required(VERSION 2.6) set_target_properties( radmon_time.x PROPERTIES COMPILE_FLAGS ${RADMON_TIME_Fortran_FLAGS} ) set_target_properties( radmon_time.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) include_directories( ${CORE_INCS} ${NCDIAG_INCS} ) - target_link_libraries( radmon_time.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ) + target_link_libraries( radmon_time.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) if(BUILD_W3NCO) add_dependencies( radmon_time.x ${W3NCO_4_LIBRARY} ) endif() diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/bad_obs.f90 b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/low_count.f90 similarity index 50% rename from util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/bad_obs.f90 rename to util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/low_count.f90 index 9962b00bb3..a35d456a12 100644 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/bad_obs.f90 +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/low_count.f90 @@ -1,12 +1,12 @@ !$$$ subprogram documentation block ! . . . -! subprogram: bad_obs build bad_obs.txt file +! subprogram: low_count build low_count.txt file ! prgmmr: safford date: 2009-11 ! -! abstract: This module contains code to build the bad_obs.txt file. -! The bad_obs.txt file reports the satellite and channel for -! which an unexpected number of observations were found in -! assimilated radiance data. +! abstract: This module contains code to build the low_count.txt file. +! The low_count.txt file reports the satellite and channel for +! which an unexpectedly low number of observations were found +! in the assimilated radiance data. ! ! program history log: ! 2009-11-23 safford - initial coding @@ -20,15 +20,15 @@ ! !$$$ -module bad_obs +module low_count implicit none private - public :: open_bad_obs_file - public :: write_bad_obs - public :: close_bad_obs_file + public :: open_low_count_file + public :: write_low_count + public :: close_low_count_file integer, parameter :: funit = 10 @@ -36,10 +36,10 @@ module bad_obs !------------------------------------------------------------- - ! create the bad_obs file + ! create the low_count file !------------------------------------------------------------- - subroutine open_bad_obs_file( date, cycle, fios ) + subroutine open_low_count_file( date, cycle, fios ) !--- interface character(8), intent( in ) :: date @@ -51,49 +51,46 @@ subroutine open_bad_obs_file( date, cycle, fios ) character(60) :: fname - write(*,*) '--> open_bad_obs_file, date, cycle = ', date, cycle + write(*,*) '--> open_low_count_file, date, cycle = ', date, cycle !--- build the file name - fname = 'bad_obs.' // trim(date) // trim(cycle) + fname = 'low_count.' // trim(date) // trim(cycle) !--- open file and write the header inquire(file=fname, exist=lexist) if( lexist .eqv. .FALSE. ) then - write(*,*) ' opening new bad_obs file' + write(*,*) ' opening new low_count file' open( UNIT=funit, FILE=fname, STATUS='NEW', IOSTAT=fios ) else - write(*,*) ' opening existing bad_obs.txt file' + write(*,*) ' opening existing low_count.txt file' open( UNIT=funit, FILE=fname, STATUS='OLD', POSITION='APPEND', IOSTAT=fios ) end if - end subroutine open_bad_obs_file + end subroutine open_low_count_file - subroutine write_bad_obs( satname, channel, region, num_obs ) + subroutine write_low_count( satname, channel, region, num_obs, avg_cnt ) !--- interface character(20), intent( in ) :: satname integer, intent( in ) :: channel integer, intent( in ) :: region real, intent( in ) :: num_obs - - !--- variables - real :: count - + real, intent( in ) :: avg_cnt !--- -! if( num_obs < 0.0 ) then -! count = 0.0 -! else - count = num_obs -! end if + character(len=50) :: fmt + + fmt = "(A16,A10,I5,A9,I1,A10,I7,A10,F9.2)" - write(funit,*) satname, 'channel= ', channel, ' region= ', region, ' num_obs= ', count + write(funit, fmt) satname, ' channel= ', channel, & + ' region= ', region, ' num_obs= ', & + INT(num_obs), ' avg_obs= ', avg_cnt - end subroutine write_bad_obs + end subroutine write_low_count - subroutine close_bad_obs_file( ) - write(*,*) '--> close_bad_obs_file' + subroutine close_low_count_file( ) + write(*,*) '--> close_low_count_file' close( funit ) - end subroutine close_bad_obs_file + end subroutine close_low_count_file -end module bad_obs +end module low_count diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/time.f90 b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/time.f90 index 395a4bb617..b53da60d01 100755 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/time.f90 +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/time.f90 @@ -9,7 +9,7 @@ program time !************************************************************************ use read_diag - use bad_obs + use low_count use bad_penalty use bad_chan use valid @@ -61,9 +61,10 @@ program time type(diag_data_chan_list ),allocatable :: data_chan(:) type(diag_data_extra_list) ,allocatable :: data_extra(:,:) - logical valid_count, valid_penalty - integer nsnow, nland, nwater, nice, nmixed, ntotal - integer nnsnow, nnland, nnwater, nnmixed, nntotal + logical valid_count, valid_penalty + integer nsnow, nland, nwater, nice, nmixed, ntotal + integer nnsnow, nnland, nnwater, nnmixed, nntotal + real avg_cnt ! Namelist with defaults logical :: retrieval = .false. @@ -147,23 +148,7 @@ program time write(6,*)'ctl_file =',ctl_file write(6,*)'suffix =',suffix -!! Open unit to diagnostic file. Read portion of -!! header to see if file exists -! open(lndiag,file=diag_rad,form='unformatted') -! read(lndiag,err=900,end=900) dum -! rewind lndiag - - !----------------------------------------------------- - ! Note: Ideally the open_radiag routine would - ! return an iret code indicating success or - ! failure of the attempt to open the diag file. - ! It's ok in this case, only because the calling - ! script only starts the executable if the - ! diag file is > 0 sized, and the calls to - ! actually read the data do support return codes. - ! Still, if time permits it would be useful to add - ! an iret value to open_radiag(). - ! + call set_netcdf_read( netcdf ) call open_radiag( diag_rad, lndiag, istatus ) @@ -199,10 +184,10 @@ program time date = stringd(2:9) cycle = stringd(10:11) -! call open_bad_obs_file( date, cycle, ios ) if ( trim(gesanl) == 'ges' ) then call open_bad_penalty_file( date, cycle, ios ) call open_bad_chan_file( date, cycle, ios ) + call open_low_count_file( date, cycle, ios ) call load_base( satname, ios ) endif @@ -328,8 +313,6 @@ program time if (data_chan(j)%errinv > 1.e-6) then pen = (data_chan(j)%errinv*(data_chan(j)%omgbc))**2 cor_tot(1) = (data_chan(j)%omgnbc - data_chan(j)%omgbc) -! nbc_omg(1) = - data_chan(j)%omgnbc -! bc_omg(1) = - data_chan(j)%omgbc omgnbc(1) = data_chan(j)%omgnbc omgbc(1) = data_chan(j)%omgbc @@ -338,8 +321,6 @@ program time omgbc(2) = (data_chan(j)%omgbc)**2 cor_tot(2) = (data_chan(j)%omgnbc - data_chan(j)%omgbc)**2 -! nbc_omg(2) = (data_chan(j)%omgnbc)**2 -! bc_omg(2) = (data_chan(j)%omgbc)**2 do i=1,nreg k=jsub(i) @@ -350,9 +331,7 @@ program time do ii=1,2 tot_cor(j,k,ii) = tot_cor(j,k,ii) + cor_tot(ii) -! omg_nbc(j,k,ii) = omg_nbc(j,k,ii) + nbc_omg(ii) omg_nbc(j,k,ii) = omg_nbc(j,k,ii) + omgnbc(ii) -! omg_bc(j,k,ii) = omg_bc(j,k,ii) + bc_omg(ii) omg_bc(j,k,ii) = omg_bc(j,k,ii) + omgbc(ii) end do @@ -379,14 +358,15 @@ program time ! --- validate the count value for region 1 (global) ! -! if ( use(j,k) > 0.0 .AND. k == 1 .AND. imkdata == 1 ) then -! call validate_count( j, k, count(j,k), valid_count, iret ) -! write (*,*) ' valid_count, iret = ', valid_count, iret -! if ( (iret == 0) .AND. (valid_count .eqv. .FALSE.) ) then -! write (*,*) ' calling write_bad_obs ' -! call write_bad_obs( satname, nu_chan(j), k, count(j,k) ) -! end if -! end if + if ( use(j,k) > 0.0 .AND. k == 1 .AND. imkdata == 1 ) then + call validate_count( j, k, count(j,k), valid_count, avg_cnt, iret ) + write (*,*) ' valid_count, iret = ', valid_count, iret + + if ( (iret == 0) .AND. (valid_count .eqv. .FALSE.) ) then + write (*,*) ' calling write_low_count ' + call write_low_count( satname, nu_chan(j), k, count(j,k), avg_cnt ) + end if + end if if (count(j,k)>0) then test_pen(j,k)=penalty(j,k)/count(j,k) @@ -414,11 +394,6 @@ program time ! it using write_bad_chan(). ! -! -! This is for testing purposes only -! channel_count(1) = 0.0 -! write(6,*)' header_chan(j)%iuse, channel_count(1) = ', header_chan(1)%iuse, channel_count(1) -! do j=1,n_chan ! write(6,*)' j, header_chan(j)%iuse, channel_count(j) = ', j, header_chan(j)%iuse, channel_count(j) ! if( header_chan(j)%iuse > 0.0 ) then @@ -441,7 +416,7 @@ program time end do ! channel loop if ( trim(gesanl) == 'ges' ) then -! call close_bad_obs_file() + call close_low_count_file() call close_bad_penalty_file() call close_bad_chan_file() endif diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/valid.f90 b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/valid.f90 index b2065e3318..445d5708c5 100755 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/valid.f90 +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd/valid.f90 @@ -47,11 +47,24 @@ module valid contains - !------------------------------------------------------------- + !-------------------------------------------------------------------------- ! load the base file for the given satellite - !------------------------------------------------------------- + ! + ! Note a change in validation for iasi and cris sources. + ! Per Kristen (2/20/20): + ! With correlated error, the contribution to penalty calculation in the + ! radmon is no longer mathematically correct. The calculated penalty is + ! expected to be larger than what it actually is. Both IASI instruments + ! will use correlated error over land and sea, and both CrIS instruments + ! will use correlated error over sea in V16. You should therefore + ! suppress/modify the warnings for IASI and CrIS. + ! + ! The agreed upon solution is to multiply the historical max penalty + ! values, making iasi 5x and cris 6x. + !--------------------------------------------------------------------------- subroutine load_base( satname, iret ) + !--- interface character(20), intent( in ) :: satname @@ -62,7 +75,7 @@ subroutine load_base( satname, iret ) character(20) test_satname character(10) base_date - integer fios + integer fios, multiply_by integer chan, region logical fexist @@ -115,6 +128,27 @@ subroutine load_base( satname, iret ) end do end do + !--------------------------------------------------- + ! adjust max_penalty values for iasi and cris + ! sources -- see explanation above + ! + +! multiply_by = 1 + +! if ( satname(1:4) == 'iasi' ) then +! multiply_by = 5 +! else if ( satname(1:4) == 'cris' ) then +! multiply_by = 6 +! end if + +! if ( multiply_by > 1 ) then +! do k=1,nregion +! do j=1,nchan +! max_penalty(j,k) = max_penalty(j,k) * multiply_by +! end do +! end do +! end if + iret = 0 base_loaded = .TRUE. else @@ -134,13 +168,14 @@ end subroutine load_base ! -2 = invalid region ! 1 = base file wasn't loaded, unable to validate !--------------------------------------------------------------- - subroutine validate_count( channel, region, count, valid, iret ) + subroutine validate_count( channel, region, count, valid, avg_cnt, iret ) !--- interface integer, intent( in ) :: channel integer, intent( in ) :: region real, intent( in ) :: count logical, intent( out ) :: valid + real, intent( out ) :: avg_cnt integer, intent( out ) :: iret !--- vars @@ -148,11 +183,13 @@ subroutine validate_count( channel, region, count, valid, iret ) write(*,*) '--> validate_count, channel, region, count ', channel, region, count !--- initialize vars - iret = 0 + iret = 0 cnt = count valid = .FALSE. + avg_cnt = 0.00 if( base_loaded .eqv. .TRUE. ) then + if( channel < 1 .OR. channel > nchan ) then iret = -1 write(*,*) 'Warning: In validate_count attempt to validate channel out of range', channel @@ -162,43 +199,45 @@ subroutine validate_count( channel, region, count, valid, iret ) write(*,*) 'Warnig: In validate_count attempt to validate region out of range', region valid = .TRUE. else - ! + !--------------------------------------------------------------------- ! all unassimilated channels in the base files will have an rmiss ! value and are considered valid for verification purposes ! + avg_cnt = avg_count( channel, region ) + if( avg_count(channel,region) < 0.0 ) then valid = .TRUE. else + !------------------------------------------------------------------ + ! Consider any count valid if: + ! cnt is within 2 sdvs from avg + ! sdv2 = 2 * sdv_count( channel, region ) - hi = avg_count(channel,region) + sdv2 lo = avg_count(channel,region) - sdv2 - ! - ! Consider any count valid if: - ! cnt is 2 sdvs from avg or - ! cnt is within the established min/max range for chan,region - ! - if( cnt > 0.0 ) then + if( cnt >= lo ) then valid = .TRUE. - end if - !if( cnt <= hi .AND. cnt >= lo ) then - ! valid = .TRUE. - !else if( (cnt > 0) .AND. (cnt >= min_count( channel,region )) .AND. & - ! (cnt <= max_count( channel,region )) ) then - ! valid = .TRUE. - !end if + end if + + if( valid .eqv. .FALSE. ) then + write(*,*) 'LOW COUNT: cnt, lo, min_count, avg_cnt = ', & + cnt, lo, min_count(channel,region), avg_cnt + end if + end if end if - if ( valid .eqv. .FALSE. ) then - write(*,*) ' avg_count(channel,region), sdv2, hi, lo = ', avg_count(channel,region), sdv2, hi, lo - end if - write (*,*) '<-- valid, iret=', valid, iret + else - !--- base file was not loaded, so return a warning that validation isn't possible + !--------------------------------------------------------- + ! base file wasn't loaded, so validation wasn't possible + ! + write(*,*) 'base file not loaded, unable to validate count' iret = 1 end if + + write (*,*) '<-- valid, iret=', valid, iret end subroutine validate_count diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_err_rpt.sh b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_err_rpt.sh index 5b68f4a7d4..4c7173ca7c 100755 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_err_rpt.sh +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_err_rpt.sh @@ -19,9 +19,6 @@ # directory before invoking this script. # # -# Script history log: -# 2012-02-02 Safford initial script -# # Usage: radmon_err_rpt.sh file1 file2 type cycle1 cycle2 diag_rpt outfile # # Input script positional parameters: @@ -30,7 +27,7 @@ # file2 obs, penalty, or channel error file # required # type type of error file -# choises are obs, pen, or chan; required +# choices are obs, pen, chan, or cnt; required # cycle1 first cycle processing date # yyyymmddcc format; required # cycle2 second cycle processing date @@ -40,24 +37,6 @@ # outfile output file name # required # -# Imported Shell Variables: -# -# HOMEradmon package's nwprod subdirectory -# defaults to pwd -# -# Exported Shell Variables: -# err Last return code -# -# Modules and files referenced: -# scripts : -# -# fixed data : $ctlfile -# -# input data : $file1 -# $file2 -# -# output data: $outfile -# # Remarks: # # Condition codes @@ -65,6 +44,8 @@ # >0 - some problem encountered #################################################################### +echo "--> radmon_err_rpt.sh" + # Command line arguments. file1=${1:-${file1:?}} file2=${2:-${file2:?}} @@ -94,7 +75,7 @@ if [[ -s $diag_rpt ]]; then else err=1 fi - +echo "have_diag_rpt = $have_diag_rpt" #----------------------------------------------------------------------------- # read each line in the $file1 @@ -102,17 +83,14 @@ fi # if same combination is in both files, add the values to the output file # { while read myline; do + echo "myline = $myline" bound="" echo $myline satname=`echo $myline | gawk '{print $1}'` - echo satname = $satname channel=`echo $myline | gawk '{print $3}'` - echo channel = $channel region=`echo $myline | gawk '{print $5}'` - echo region = $region value1=`echo $myline | gawk '{print $7}'` - echo value1 = $value1 bound=`echo $myline | gawk '{print $9}'` # @@ -136,11 +114,8 @@ fi if [[ $type == "chan" ]]; then echo "looking for match for $satname and $channel" { while read myline2; do - echo $myline satname2=`echo $myline2 | gawk '{print $1}'` - echo satname = $satname channel2=`echo $myline2 | gawk '{print $3}'` - echo channel = $channel if [[ $satname == $satname2 && $channel == $channel2 ]]; then match="$satname channel= $channel" @@ -151,6 +126,7 @@ fi fi done } < $file2 + else match=`gawk "/$satname/ && /channel= $channel / && /region= $region /" $file2` @@ -159,17 +135,17 @@ fi match_len=`echo ${#match}` if [[ $match_len > 0 ]]; then channel2=`echo $match | gawk '{print $3}'` - echo channel2 = $channel2 + if [[ $channel2 != $channel ]]; then match="" fi fi - echo match = $match + fi match_len=`echo ${#match}` if [[ $match_len > 0 ]]; then - echo $match_len + value2=`echo $match | gawk '{print $7}'` bound2=`echo $match | gawk '{print $9}'` @@ -181,6 +157,10 @@ fi tmpa="$satname channel= $channel region= $region" tmpb="$cycle1 $value1 $bound" + elif [[ $type == "cnt" ]]; then + tmpa="$satname channel= $channel region= $region" + tmpb="$cycle1 $value1 $bound" + else tmpa="$satname channel= $channel region= $region" tmpb="$cycle1: $type= $value1" @@ -192,7 +172,7 @@ fi if [[ $type != "chan" ]]; then tmpc=`echo $tmpa |sed 's/[a-z]/ /g' | sed 's/[0-9]/ /g' | sed 's/=/ /g' | sed 's/_/ /g' | sed 's/-/ /g'` - if [[ $type == "pen" ]]; then + if [[ $type == "pen" || $type == "cnt" ]]; then line2=" $tmpc $cycle2 $value2 $bound2" else line2=" $tmpc $cycle2: $type= $value2" @@ -201,15 +181,9 @@ fi echo "$line2" >> $outfile fi - #---------------------------------------------------------- - # Access the control file to deterimine channel grouping - # number. Not all sources have consecutively numbered - # channels, and we need to map the channel to the correct - # grouping number in order to produce an accurate hyperlink. - # - # Update: with the new js plotting the actual channel number - # can be sent so the chgrp is no longer used here. - + !----------------------------------------- + ! add hyperlink to warning entry + ! line3=" http://www.emc.ncep.noaa.gov/gmb/gdas/radiance/es_rad/${RADMON_SUFFIX}/index.html?sat=${satname}®ion=${region}&channel=${channel}&stat=${type}" if [[ $channel -gt 0 ]]; then echo "$line3" >> $outfile @@ -226,6 +200,7 @@ if [[ "$VERBOSE" = "YES" ]]; then echo $(date) EXITING $0 with error code ${err} >&2 fi +echo "<-- radmon_err_rpt.sh" set +x exit ${err} diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_time.sh b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_time.sh index c52e272c7b..ba42a0dba4 100755 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_time.sh +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_time.sh @@ -88,9 +88,6 @@ # Command line arguments. export PDATE=${1:-${PDATE:?}} -scr=radmon_verf_time.sh -msg="${scr} HAS STARTED" -postmsg "$jlogfile" "$msg" if [[ "$VERBOSE" = "YES" ]]; then set -ax @@ -102,23 +99,28 @@ EXECradmon=${EXECradmon:-$(pwd)} TANKverf_rad=${TANKverf_rad:-$(pwd)} # File names -pgmout=${pgmout:-${jlogfile}} -touch $pgmout +#pgmout=${pgmout:-${jlogfile}} +#touch $pgmout radmon_err_rpt=${radmon_err_rpt:-${USHradmon}/radmon_err_rpt.sh} base_file=${base_file:-$FIXgdas/gdas_radmon_base.tar} report=report.txt disclaimer=disclaimer.txt region=region.txt + diag_report=diag_report.txt diag_hdr=diag_hdr.txt diag=diag.txt + obs_err=obs_err.txt obs_hdr=obs_hdr.txt pen_err=pen_err.txt pen_hdr=pen_hdr.txt + chan_err=chan_err.txt chan_hdr=chan_hdr.txt +count_hdr=count_hdr.txt +count_err=count_err.txt netcdf_boolean=".false." if [[ $RADMON_NETCDF -eq 1 ]]; then @@ -139,7 +141,6 @@ MAIL_TO=${MAIL_TO:-} MAIL_CC=${MAIL_CC:-} VERBOSE=${VERBOSE:-NO} LITTLE_ENDIAN=${LITTLE_ENDIAN:-0} -USE_MAIL=${USE_MAIL:-0} time_exec=radmon_time.x USE_ANL=${USE_ANL:-0} @@ -206,8 +207,6 @@ if [[ $err -eq 0 ]]; then for dtype in ${gesanl}; do - prep_step - rm input if [[ $dtype == "anl" ]]; then @@ -249,17 +248,9 @@ cat << EOF > input netcdf=${netcdf_boolean}, / EOF - startmsg ./${time_exec} < input >> stdout.${type} 2>>errfile - export err=$?; err_chk - - # - # stdout.${type} is needed by radmon_ck_stdout.sh - # NCO requirement is executable output goes to jlogfile, so - # cat it there now: - cat stdout.${type} >> ${pgmout} - + if [[ $err -ne 0 ]]; then fail=`expr $fail + 1` fi @@ -267,7 +258,7 @@ EOF #------------------------------------------------------------------- # move data, control, and stdout files to $TANKverf_rad and compress #------------------------------------------------------------------- - + cat stdout.${type} >> stdout.time if [[ -s ${time_file} ]]; then ${COMPRESS} ${time_file} @@ -349,12 +340,10 @@ EOF cat ${diag_hdr} >> ${diag_report} cat ${diag} >> ${diag_report} - if [[ $USE_MAIL -eq 1 ]]; then - cat ${disclaimer} >> ${diag_report} - else - echo End Problem Reading Diagnostic File >> ${diag_report} - echo >> ${diag_report} - fi + + echo End Problem Reading Diagnostic File >> ${diag_report} + echo >> ${diag_report} + rm ${diag} ${diag_hdr} fi @@ -363,18 +352,10 @@ EOF if [[ -s ${diag_report} ]]; then lines=`wc -l <${diag_report}` - if [[ $lines -gt 1 ]]; then + echo "lines in diag_report = $lines" - if [[ $USE_MAIL -eq 1 ]]; then - if [[ $MAIL_CC == "" ]]; then - /bin/mail -v -s diagnostic_error_report ${MAIL_TO}< ${diag_report} - else - /bin/mail -v -s diagnostic_error_report -c "${MAIL_CC}" ${MAIL_TO}< ${diag_report} - fi - else - - cat ${diag_report} - fi + if [[ $lines -gt 1 ]]; then + cat ${diag_report} fi fi @@ -392,27 +373,51 @@ if [[ $DO_DATA_RPT -eq 1 ]]; then bad_pen=bad_pen.${PDATE} bad_chan=bad_chan.${PDATE} + low_count=low_count.${PDATE} qdate=`$NDATE -${CYCLE_INTERVAL} $PDATE` pday=`echo $qdate | cut -c1-8` prev_bad_pen=bad_pen.${qdate} prev_bad_chan=bad_chan.${qdate} + prev_low_count=low_count.${qdate} + + prev_bad_pen=${TANKverf_radM1}/${prev_bad_pen} + prev_bad_chan=${TANKverf_radM1}/${prev_bad_chan} + prev_low_count=${TANKverf_radM1}/${prev_low_count} + + if [[ -s $bad_pen ]]; then + echo "pad_pen = $bad_pen" + fi + if [[ -s $prev_bad_pen ]]; then + echo "prev_pad_pen = $prev_bad_pen" + fi -# if [[ $CYCLE == "00" ]]; then - prev_bad_pen=${TANKverf_radM1}/${prev_bad_pen} - prev_bad_chan=${TANKverf_radM1}/${prev_bad_chan} -# else -# prev_bad_pen=${TANKverf_rad}/${prev_bad_pen} -# prev_bad_chan=${TANKverf_rad}/${prev_bad_chan} -# fi + if [[ -s $bad_chan ]]; then + echo "bad_chan = $bad_chan" + fi + if [[ -s $prev_bad_chan ]]; then + echo "prev_bad_chan = $prev_bad_chan" + fi + if [[ -s $low_count ]]; then + echo "low_count = $low_count" + fi + if [[ -s $prev_low_count ]]; then + echo "prev_low_count = $prev_low_count" + fi do_pen=0 do_chan=0 + do_cnt=0 + if [[ -s $bad_pen && -s $prev_bad_pen ]]; then do_pen=1 fi + if [[ -s $low_count && -s $prev_low_count ]]; then + do_cnt=1 + fi + #-------------------------------------------------------------------- # avoid doing the bad_chan report for REGIONAL_RR sources -- because # they run hourly they often have 0 count channels for off-hour runs. @@ -421,52 +426,65 @@ if [[ $DO_DATA_RPT -eq 1 ]]; then do_chan=1 fi -#-------------------------------------------------------------------- -# Remove extra spaces in new bad_pen file -# + #-------------------------------------------------------------------- + # Remove extra spaces in new bad_pen & low_count files + # gawk '{$1=$1}1' $bad_pen > tmp.bad_pen mv -f tmp.bad_pen $bad_pen + gawk '{$1=$1}1' $low_count > tmp.low_count + mv -f tmp.low_count $low_count - if [[ $do_pen -eq 1 || $do_chan -eq 1 ]]; then + echo " do_pen, do_chan, do_cnt = $do_pen, $do_chan, $do_cnt" + echo " diag_report = $diag_report " + if [[ $do_pen -eq 1 || $do_chan -eq 1 || $do_cnt -eq 1 ]]; then if [[ $do_pen -eq 1 ]]; then - $NCP ${TANKverf_radM1}/${prev_bad_pen} ./ + echo "calling radmon_err_rpt for pen" +# $NCP ${TANKverf_radM1}/${prev_bad_pen} ./ ${radmon_err_rpt} ${prev_bad_pen} ${bad_pen} pen ${qdate} \ ${PDATE} ${diag_report} ${pen_err} fi if [[ $do_chan -eq 1 ]]; then - $NCP ${TANKverf_radM1}/${prev_bad_chan} ./ + echo "calling radmon_err_rpt for chan" +# $NCP ${TANKverf_radM1}/${prev_bad_chan} ./ ${radmon_err_rpt} ${prev_bad_chan} ${bad_chan} chan ${qdate} \ ${PDATE} ${diag_report} ${chan_err} fi -#------------------------------------------------------------------- -# put together the unified error report with any obs, chan, and -# penalty problems and mail it + if [[ $do_cnt -eq 1 ]]; then - if [[ -s ${obs_err} || -s ${pen_err} || -s ${chan_err} ]]; then + echo "calling radmon_err_rpt for cnt" + ${radmon_err_rpt} ${prev_low_count} ${low_count} cnt ${qdate} \ + ${PDATE} ${diag_report} ${count_err} + fi + + #------------------------------------------------------------------- + # put together the unified error report with any obs, chan, and + # penalty problems and mail it - echo DOING ERROR REPORTING + if [[ -s ${obs_err} || -s ${pen_err} || -s ${chan_err} || -s ${count_err} ]]; then - echo "Begin Cycle Data Integrity Report" > $report + echo DOING ERROR REPORTING - cat << EOF >> $report + echo "Begin Cycle Data Integrity Report" > $report + + cat << EOF >> $report Cycle Data Integrity Report $PDATE EOF - cat ${region} >> $report + cat ${region} >> $report - if [[ -s ${chan_err} ]]; then + if [[ -s ${chan_err} ]]; then - echo OUTPUTING CHAN_ERR + echo OUTPUTING CHAN_ERR - cat << EOF > ${chan_hdr} + cat << EOF > ${chan_hdr} The following channels report 0 observational counts over the past two cycles: @@ -475,14 +493,32 @@ EOF EOF - cat ${chan_hdr} >> $report - cat ${chan_err} >> $report + cat ${chan_hdr} >> $report + cat ${chan_err} >> $report - fi + fi + + if [[ -s ${count_err} ]]; then + + cat << EOF > ${count_hdr} - if [[ -s ${pen_err} ]]; then - cat << EOF > ${pen_hdr} + + The following channels report abnormally low observational counts in the latest 2 cycles: + +Satellite/Instrument Obs Count Avg Count +==================== ========= ========= + +EOF + + cat ${count_hdr} >> $report + cat ${count_err} >> $report + fi + + + if [[ -s ${pen_err} ]]; then + + cat << EOF > ${pen_hdr} Penalty values outside of the established normal range were found @@ -492,43 +528,32 @@ EOF ============ ======= ====== Cycle Penalty Bound ----- ------- ----- EOF - cat ${pen_hdr} >> $report - cat ${pen_err} >> $report - rm -f ${pen_hdr} - rm -f ${pen_err} - fi - - if [[ $USE_MAIL -eq 1 ]]; then - cat ${disclaimer} >> $report - else + cat ${pen_hdr} >> $report + cat ${pen_err} >> $report + rm -f ${pen_hdr} + rm -f ${pen_err} + fi + echo End Cycle Data Integrity Report >> $report echo >> $report fi - fi -#------------------------------------------------------------------- -# mail error notifications or dump to log file -# - if [[ -s ${report} ]]; then - lines=`wc -l <${report}` - if [[ $lines -gt 2 ]]; then - if [[ $USE_MAIL -eq 1 ]]; then - if [[ $MAIL_CC == "" ]]; then - /bin/mail -v -s cycle_report ${MAIL_TO}< ${report} - else - /bin/mail -v -s cycle_report -c "${MAIL_CC}" ${MAIL_TO}< ${report} - fi - else + #------------------------------------------------------------------- + # dump report to log file + # + if [[ -s ${report} ]]; then + lines=`wc -l <${report}` + if [[ $lines -gt 2 ]]; then cat ${report} fi fi - fi - fi -#------------------------------------------------------------------- -# copy new bad_pen and bad_chan files to $TANKverf_rad - + fi + + #------------------------------------------------------------------- + # copy new bad_pen, bad_chan, and low_count files to $TANKverf_rad + # if [[ -s ${bad_chan} ]]; then $NCP ${bad_chan} ${TANKverf_rad}/. fi @@ -537,25 +562,25 @@ EOF $NCP ${bad_pen} ${TANKverf_rad}/. fi + if [[ -s ${low_count} ]]; then + $NCP ${low_count} ${TANKverf_rad}/. + fi fi -for type in ${SATYPE}; do - rm -f stdout.${type} -done - -################################################################################ -#------------------------------------------------------------------- -# end error reporting section -#------------------------------------------------------------------- -################################################################################ + for type in ${SATYPE}; do + rm -f stdout.${type} + done -################################################################################ -# Post processing -if [[ "$VERBOSE" = "YES" ]]; then - echo $(date) EXITING $0 error code ${err} >&2 -fi + ################################################################################ + #------------------------------------------------------------------- + # end error reporting section + #------------------------------------------------------------------- + ################################################################################ -msg="${scr} HAS ENDED, err code = $err" -postmsg "$jlogfile" "$msg" + ################################################################################ + # Post processing + if [[ "$VERBOSE" = "YES" ]]; then + echo $(date) EXITING $0 error code ${err} >&2 + fi exit ${err} diff --git a/util/netcdf_io/CMakeLists.txt b/util/netcdf_io/CMakeLists.txt new file mode 100644 index 0000000000..c878bb13f7 --- /dev/null +++ b/util/netcdf_io/CMakeLists.txt @@ -0,0 +1,23 @@ +cmake_minimum_required(VERSION 2.6) +MACRO(SUBDIRLIST result curdir) + FILE(GLOB children RELATIVE ${curdir} ${curdir}/*.fd) + SET(dirlist "") + FOREACH(child ${children}) + IF(IS_DIRECTORY ${curdir}/${child}) + LIST(APPEND dirlist ${child}) + ENDIF() + ENDFOREACH() + SET(${result} ${dirlist}) +ENDMACRO() + +if(BUILD_NCIO_UTIL) + set(CMAKE_Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/util/include") + set(UTIL_INC ${CMAKE_Fortran_MODULE_DIRECTORY}) + + SUBDIRLIST(SUBDIRS ${CMAKE_CURRENT_SOURCE_DIR}) + foreach(dir ${SUBDIRS}) + message("Configuring utility in ${dir}") + add_subdirectory(${dir}) + endforeach() +endif(BUILD_NCIO_UTIL) + diff --git a/util/netcdf_io/calc_analysis.fd/CMakeLists.txt b/util/netcdf_io/calc_analysis.fd/CMakeLists.txt new file mode 100644 index 0000000000..06927e8e7c --- /dev/null +++ b/util/netcdf_io/calc_analysis.fd/CMakeLists.txt @@ -0,0 +1,13 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_NCIO_UTIL) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + + set(Util_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/calc_analysis") + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + add_executable(calc_analysis.x ${LOCAL_SRC} ) + set_target_properties( calc_analysis.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + set_target_properties( calc_analysis.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} ${FV3GFS_NCIO_INCS}) + target_link_libraries( calc_analysis.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} ${FV3GFS_NCIO_LIBRARIES}) +endif() diff --git a/util/netcdf_io/calc_analysis.fd/inc2anl.f90 b/util/netcdf_io/calc_analysis.fd/inc2anl.f90 new file mode 100644 index 0000000000..f18aace835 --- /dev/null +++ b/util/netcdf_io/calc_analysis.fd/inc2anl.f90 @@ -0,0 +1,278 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! module inc2anl +!! contains subroutines for calculating analysis fields +!! for a given input background and increment +!! Original: 2019-09-18 martin - original module +!! 2019-10-24 martin - removed support for NEMSIO background but +!! allows for either NEMSIO or netCDF analysis write +!! 2020-01-21 martin - parallel IO support added +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module inc2anl + implicit none + + private + + public :: gen_anl, close_files + + integer, parameter :: nincv=10 + character(len=7) :: incvars_nemsio(nincv), incvars_netcdf(nincv), incvars_ncio(nincv) + integer, parameter :: nnciov=20 + character(len=7) :: iovars_netcdf(nnciov) + + data incvars_nemsio / 'ugrd ', 'vgrd ', 'dpres ', 'delz ', 'o3mr ',& + 'tmp ', 'spfh ', 'clwmr ', 'icmr ', 'pres '/ + data incvars_netcdf / 'u ', 'v ', 'delp ', 'delz ', 'o3mr ',& + 'T ', 'sphum ', 'liq_wat', 'icmr ', 'pres '/ + data incvars_ncio / 'ugrd ', 'vgrd ', 'dpres ', 'delz ', 'o3mr ',& + 'tmp ', 'spfh ', 'clwmr ', 'icmr ', 'pressfc'/ + data iovars_netcdf / 'grid_xt', 'grid_yt', 'pfull ', 'phalf ', 'clwmr ',& + 'delz ', 'dpres ', 'dzdt ', 'grle ', 'hgtsfc ',& + 'icmr ', 'o3mr ', 'pressfc', 'rwmr ', 'snmr ',& + 'spfh ', 'tmp ', 'ugrd ', 'vgrd ', 'cld_amt'/ + +contains + subroutine gen_anl + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! subroutine gen_anl + ! loop through fields, read in first guess, read in + ! increment, add the two together, and write out + ! the analysis to a new file + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use vars_calc_analysis, only: mype + implicit none + ! variables local to this subroutine + integer :: i, j, iincvar + logical :: use_increment + + + ! loop through each variable in the background file + do i=1,nnciov + use_increment = .false. + iincvar = -999 + ! determine if we are computing the increment for this field + do j=1,nincv + if (iovars_netcdf(i) == incvars_ncio(j)) then + use_increment = .true. + iincvar = j + end if + end do + if (use_increment) then + if (iovars_netcdf(i) == 'pressfc') then + ! special case for surface pressure + if (mype==0) print *, 'Computing and Adding Surface Pressure Increment' + call add_psfc_increment + else + ! call generic subroutine for all other fields + if (mype==0) print *, 'Adding Increment to ', iovars_netcdf(i), incvars_netcdf(iincvar) + call add_increment(iovars_netcdf(i), incvars_netcdf(iincvar)) + end if + else + ! otherwise just write out what is in the input to the output + if (mype==0) print *, 'Copying from Background ', iovars_netcdf(i) + call copy_ges_to_anl(iovars_netcdf(i)) + end if + end do + + end subroutine gen_anl + + subroutine close_files + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! subroutine close_files + ! close netCDF files before ending program + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use vars_calc_analysis, only: fcstncfile, anlncfile + use module_fv3gfs_ncio, only: close_dataset + implicit none + + call close_dataset(fcstncfile) + call close_dataset(anlncfile) + end subroutine close_files + + subroutine copy_ges_to_anl(varname) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! subroutine copy_ges_to_anl + ! generic subroutine for copying guess fields directly to + ! a new analysis file + ! args: + ! varname - input string of variable to process + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use vars_calc_analysis, only: fcstncfile, anlncfile, & + nlat, nlon, nlev, anlfile, use_nemsio_anl, & + mype, levpe + use module_fv3gfs_ncio, only: Dataset, read_vardata, write_vardata, & + open_dataset, close_dataset, has_var + use nemsio_module + implicit none + character(7), intent(in) :: varname + real, allocatable, dimension(:) :: work1d + real, allocatable, dimension(:,:) :: work2d + real(8), allocatable, dimension(:) :: work1d8 + real(8), allocatable, dimension(:,:) :: work2d8 + real, allocatable, dimension(:,:,:) :: work3d + integer :: iret, k, krev + + if (has_var(fcstncfile, varname)) then + select case (varname) + case ('grid_xt', 'grid_yt') + if (.not. use_nemsio_anl) then + call read_vardata(fcstncfile, varname, work1d8) + call write_vardata(anlncfile, varname, work1d8) + end if + case ('pfull ', 'phalf ') + if (.not. use_nemsio_anl) then + call read_vardata(fcstncfile, varname, work1d) + call write_vardata(anlncfile, varname, work1d) + end if + case ('lat ', 'lon ') + if (.not. use_nemsio_anl) then + call read_vardata(fcstncfile, varname, work2d8) + call write_vardata(anlncfile, varname, work2d8) + end if + case ('hgtsfc ') + call read_vardata(fcstncfile, varname, work2d) + if (use_nemsio_anl) then + if (.not. allocated(work1d)) allocate(work1d(nlat*nlon)) + work1d = reshape(work2d,(/size(work1d)/)) + call nemsio_writerecv(anlfile, 'hgt', 'sfc', 1, work1d, iret=iret) + if (iret /=0) write(6,*) 'Error with NEMSIO write', 'hgt', 'sfc', 1, 'iret=',iret + else + call write_vardata(anlncfile, varname, work2d) + end if + case default + if (use_nemsio_anl) then + call read_vardata(fcstncfile, varname, work3d) + if (.not. allocated(work1d)) allocate(work1d(nlat*nlon)) + do k=1,nlev + krev = (nlev+1)-k + work1d = reshape(work3d(:,:,krev),(/size(work1d)/)) + call nemsio_writerecv(anlfile, trim(varname), 'mid layer', k, work1d, iret=iret) + if (iret /=0) write(6,*) 'Error with NEMSIO write', trim(varname), 'mid layer', k, 'iret=',iret + end do + else + do k=1,nlev + if (mype == levpe(k)) then + call read_vardata(fcstncfile, varname, work3d, nslice=k, slicedim=3) + call write_vardata(anlncfile, varname, work3d, nslice=k, slicedim=3) + end if + end do + end if + end select + else + if (mype == 0) write(6,*) varname, 'not in background file, skipping...' + end if + + end subroutine copy_ges_to_anl + + subroutine add_increment(fcstvar, incvar) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! subroutine add_increment + ! generic subroutine for adding increment to background + ! and writing out to analysis + ! args: + ! fcstvar - input string of netCDF fcst/anal var name + ! incvar - input string of netCDF increment var name + ! (without _inc suffix added) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use vars_calc_analysis, only: fcstncfile, anlncfile, incr_file,& + nlat, nlon, nlev, anlfile, use_nemsio_anl, & + levpe, mype + use module_fv3gfs_ncio, only: Dataset, read_vardata, write_vardata, & + open_dataset, close_dataset, has_var + use nemsio_module + implicit none + ! input vars + character(7), intent(in) :: fcstvar, incvar + ! local variables + real, allocatable, dimension(:,:,:) :: work3d_bg + real, allocatable, dimension(:,:) :: work3d_inc + real, allocatable, dimension(:) :: work1d + integer :: j,jj,k,krev,iret + type(Dataset) :: incncfile + + if (has_var(fcstncfile, fcstvar)) then + do k=1,nlev + if (mype == levpe(k)) then + ! get first guess + call read_vardata(fcstncfile, fcstvar, work3d_bg, nslice=k, slicedim=3) + ! get increment + incncfile = open_dataset(incr_file, paropen=.true.) + call read_vardata(incncfile, trim(incvar)//"_inc", work3d_inc, nslice=k, slicedim=3) + ! add increment to background + do j=1,nlat + jj=nlat+1-j ! increment is S->N, history files are N->S + work3d_bg(:,j,1) = work3d_bg(:,j,1) + work3d_inc(:,jj) + end do + ! write out analysis to file + if (use_nemsio_anl) then + allocate(work1d(nlat*nlon)) + krev = (nlev+1)-k + work1d = reshape(work3d_bg(:,:,krev),(/size(work1d)/)) + call nemsio_writerecv(anlfile, trim(fcstvar), 'mid layer', k, work1d, iret=iret) + if (iret /=0) write(6,*) 'Error with NEMSIO write', trim(fcstvar), 'mid layer', k, 'iret=',iret + deallocate(work1d) + else + call write_vardata(anlncfile, fcstvar, work3d_bg, nslice=k, slicedim=3) + end if + end if + end do + ! clean up and close + deallocate(work3d_bg, work3d_inc) + call close_dataset(incncfile) + else + write(6,*) fcstvar, ' not in background file, skipping...' + end if + + end subroutine add_increment + + subroutine add_psfc_increment + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! subroutine add_psfc_increment + ! special case of getting surface pressure analysis from + ! bk5 and delp increment to get sfc pressure increment + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use vars_calc_analysis, only: fcstncfile, anlncfile, nlat, nlon, incr_file,& + use_nemsio_anl, anlfile, nlev + use module_fv3gfs_ncio, only: Dataset, open_dataset, close_dataset,& + read_vardata, write_vardata, read_attribute + use nemsio_module + implicit none + ! local variables + real, allocatable, dimension(:,:,:) :: work3d_inc + real, allocatable, dimension(:,:) :: ps_inc, work2d + real, allocatable, dimension(:) :: bk5, work1d + integer :: iret, j, jj + type(Dataset) :: incncfile + + ! get bk5 from attributes + call read_attribute(fcstncfile, 'bk', bk5) + ! read in delp increment to get ps increment + incncfile = open_dataset(incr_file) + call read_vardata(incncfile, 'delp_inc', work3d_inc) + ! get ps increment from delp increment and bk + allocate(ps_inc(nlon,nlat)) + ps_inc(:,:) = work3d_inc(:,:,nlev) / (bk5(nlev) - bk5(nlev-1)) + ! read in psfc background + call read_vardata(fcstncfile, 'pressfc', work2d) + ! add increment to background + do j=1,nlat + jj=nlat+1-j ! increment is S->N, history file is N->S + work2d(:,j) = work2d(:,j) + ps_inc(:,jj) + end do + ! write out to file + if (use_nemsio_anl) then + allocate(work1d(nlon*nlat)) + ! now write out new psfc to NEMSIO analysis file + work1d = reshape(work2d,(/size(work1d)/)) + call nemsio_writerecv(anlfile, 'pres', 'sfc', 1, work1d, iret=iret) + if (iret /=0) write(6,*) 'Error with NEMSIO write sfc pressure' + deallocate(work1d) + else + call write_vardata(anlncfile, 'pressfc', work2d) + end if + ! deallocate and close + call close_dataset(incncfile) + deallocate(work2d,work3d_inc,ps_inc,bk5) + + end subroutine add_psfc_increment + +end module inc2anl diff --git a/util/netcdf_io/calc_analysis.fd/init_calc_analysis.f90 b/util/netcdf_io/calc_analysis.fd/init_calc_analysis.f90 new file mode 100644 index 0000000000..2d7c922da7 --- /dev/null +++ b/util/netcdf_io/calc_analysis.fd/init_calc_analysis.f90 @@ -0,0 +1,64 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! module init_calc_analysis +!! contains subroutines for reading namelist +!! for calc_analysis utility +!! Original: 2019-09-18 martin - original module +!! 2019-09-25 martin - update to allow for netCDF I/O +!! 2019-10-24 martin - update to support nemsio output +!! 2020-01-17 martin - parallel IO support added +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module init_calc_analysis + implicit none +contains + subroutine read_nml + !! read in namelist parameters from + !! calc_analysis.nml file in same directory + !! as executable + use vars_calc_analysis, only: anal_file, fcst_file, incr_file, use_nemsio_anl, fhr, mype, npes + implicit none + ! local variables to this subroutine + character(len=500) :: datapath = './' + character(len=500) :: analysis_filename = 'atmanl.nc' + character(len=500) :: firstguess_filename = 'atmges.nc' + character(len=500) :: increment_filename = 'atminc.nc' + character(len=2) :: hrstr + integer, parameter :: lunit = 10 + logical :: lexist = .false. + namelist /setup/ datapath, analysis_filename, firstguess_filename, increment_filename, fhr, use_nemsio_anl + + fhr = 6 ! default to 6 hour cycle only + use_nemsio_anl = .false. ! default to using netCDF for background and analysis + + ! read in the namelist + inquire(file='calc_analysis.nml', exist=lexist) + if ( lexist ) then + open(file='calc_analysis.nml', unit=lunit, status='old', & + form='formatted', action='read', access='sequential') + read(lunit,nml=setup) + close(lunit) + else + write(6,*) 'calc_analysis.nml does not exist and should, ABORT!' + stop 99 + end if + + write(hrstr,'(I0.2)') fhr + anal_file = trim(adjustl(datapath)) // '/' // trim(adjustl(analysis_filename)) // '.' // hrstr + fcst_file = trim(adjustl(datapath)) // '/' // trim(adjustl(firstguess_filename)) // '.' // hrstr + incr_file = trim(adjustl(datapath)) // '/' // trim(adjustl(increment_filename)) // '.' // hrstr + + if (mype == 0) then + write(6,*) 'Analysis File = ', trim(anal_file) + write(6,*) 'First Guess File = ', trim(fcst_file) + write(6,*) 'Increment File = ', trim(incr_file) + write(6,*) 'Forecast Hour = ', fhr + write(6,*) 'Number of PEs = ', npes + write(6,*) 'input guess file and increment file should be in netCDF format' + if (use_nemsio_anl) then + write(6,*) 'writing analysis in NEMSIO format' + else + write(6,*) 'writing analysis in netCDF format' + end if + end if + + end subroutine read_nml +end module init_calc_analysis diff --git a/util/netcdf_io/calc_analysis.fd/init_io.f90 b/util/netcdf_io/calc_analysis.fd/init_io.f90 new file mode 100644 index 0000000000..4390b36b65 --- /dev/null +++ b/util/netcdf_io/calc_analysis.fd/init_io.f90 @@ -0,0 +1,217 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! module init_io +!! contains subroutines for initializing background +!! and analysis files IO +!! Original: 2019-09-18 martin - original module +!! 2019-09-27 martin - added support for netCDF IO +!! 2019-10-24 martin - support NEMSIO analysis write +!! 2020-01-21 martin - parallel IO support added +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module init_io + use nemsio_module + implicit none + + private + + public :: init_read_bg + public :: init_write_anl + +contains + subroutine init_read_bg + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! subroutine read_bg + ! read first guess file + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use vars_calc_analysis, only: fcst_file, fcstncfile, & + idate6, nlon, nlat, nlev, & + use_nemsio_anl, lats, lons, vcoord, & + mype, npes, levpe + use module_fv3gfs_ncio, only: Dimension, open_dataset, get_dim,& + get_idate_from_time_units, & + read_vardata, read_attribute + implicit none + ! variables local to this subroutine + integer ::k,kk,ilev + type(Dimension) :: ncdim + real, allocatable, dimension(:) :: ak, bk + real, allocatable, dimension(:,:) :: tmp2d + + ! open the background file + fcstncfile = open_dataset(fcst_file, paropen=.true.) + ! get dimensions + ncdim = get_dim(fcstncfile,'grid_xt'); nlon=ncdim%len + ncdim = get_dim(fcstncfile,'grid_yt'); nlat=ncdim%len + ncdim = get_dim(fcstncfile,'pfull'); nlev=ncdim%len + ! get valid time + idate6 = get_idate_from_time_units(fcstncfile) + if (mype==0) then + write(6,*) 'Background initialization date=', idate6 + write(6,*) 'nlon=', nlon + write(6,*) 'nlat=', nlat + write(6,*) 'nlev=', nlev + end if + ! determine which PEs will be used for each model level + ilev = 0 + allocate(levpe(nlev)) + do k=1,nlev + levpe(k) = ilev + ilev = ilev + 1 + if (ilev == npes) ilev = 0 + end do + + ! need to extract lat, lon, vcoord info + if (use_nemsio_anl) then + allocate(lats(nlon*nlat),lons(nlon*nlat)) + call read_vardata(fcstncfile, 'lon', tmp2d) + lons = reshape(tmp2d,(/nlon*nlat/)) + call read_vardata(fcstncfile, 'lat', tmp2d) + lats = reshape(tmp2d,(/nlon*nlat/)) + call read_attribute(fcstncfile, 'bk', bk) + call read_attribute(fcstncfile, 'ak', ak) + allocate(vcoord(nlev+1,3,2)) + do k=1,nlev+1 + kk = nlev+2-k + vcoord(k,1,1) = ak(kk) + vcoord(k,2,1) = bk(kk) + vcoord(k,3,1) = 0 + end do + end if + + end subroutine init_read_bg + + subroutine init_write_anl + use vars_calc_analysis, only: anal_file, anlfile, jdate, idate6, jdate6,& + fhr, nfhour, nfminute, nfsecondn, nfsecondd,& + use_nemsio_anl, anlncfile, fcstncfile,& + nlon, nlat, nlev, lats, lons, vcoord, mype + use module_fv3gfs_ncio, only: create_dataset, get_time_units_from_idate,& + write_vardata, write_attribute + use netcdf, only: nf90_max_name + use nemsio_module + implicit none + ! variables local to this subroutine + integer :: iret, nrecs + real, dimension(5) :: fha + integer, dimension(8) :: ida, jda + character(len=nf90_max_name) :: time_units + real,allocatable,dimension(:) :: fhour + ! nemsio variables needed + character(nemsio_charkind), allocatable :: recname(:), reclevtyp(:), variname(:) + character(nemsio_charkind), allocatable :: varcname(:), varcval(:) + integer(nemsio_intkind), allocatable :: reclev(:), varival(:) + character(len=7) :: iovars_recs(16) + character(len=9) :: iovars_levs(16) + data iovars_recs / 'ugrd ', 'vgrd ', 'dzdt ', 'delz ', 'tmp ',& + 'dpres ', 'spfh ', 'clwmr ', 'rwmr ', 'icmr ',& + 'snmr ', 'grle ', 'o3mr ', 'cld_amt', 'pres ',& + 'hgt '/ + data iovars_levs / 'mid layer', 'mid layer', 'mid layer', 'mid layer',& + 'mid layer', 'mid layer', 'mid layer', 'mid layer',& + 'mid layer', 'mid layer', 'mid layer', 'mid layer',& + 'mid layer', 'mid layer', 'sfc ', 'sfc '/ + integer :: irec, ii + + ! modify dates for analysis file + ida(:) = 0 + jda(:) = 0 + fha(:) = 0 + fha(2) = fhr + + ida(1)=idate6(1) + ida(2)=idate6(2) + ida(3)=idate6(3) + ida(4)=0 + ida(5)=idate6(4) + ida(6)=idate6(5) + call w3movdat(fha,ida,jda) + nfhour=0 + nfminute=0 + nfsecondn=0 + nfsecondd=1 + jdate6(1)=jda(1) + jdate6(2)=jda(2) + jdate6(3)=jda(3) + jdate6(4)=jda(5) + jdate6(5)=idate6(5) + jdate6(6)=0 + if (mype==0) write(6,*) 'Analysis valid date=', jdate6 + jdate(1:6)=jdate6 + jdate(7)=1 + + if (use_nemsio_anl) then + ! compute nrecs + nrecs = (nlev*14) + 2 + ! get recnames, etc. + allocate(recname(nrecs),reclevtyp(nrecs),reclev(nrecs)) + ii=1 + do irec=1,nrecs-2 + recname(irec) = iovars_recs(ii) + reclevtyp(irec) = iovars_levs(ii) + reclev(irec) = modulo(irec,nlev) + if (modulo(irec,nlev)==0) then + reclev(irec) = nlev + ii=ii+1 + end if + end do + recname(nrecs-1) = iovars_recs(15) + reclevtyp(nrecs-1) = iovars_levs(15) + reclev(nrecs-1) = 1 + recname(nrecs) = iovars_recs(16) + reclevtyp(nrecs) = iovars_levs(16) + reclev(nrecs) = 1 + + ! more metadata + allocate(variname(3), varival(3), varcname(5), varcval(5)) + variname(1) = 'ncnsto' + variname(2) = 'im' + variname(3) = 'jm' + varival(1) = 9 + varival(2) = nlon + varival(3) = nlat + varcname(1) = 'hydrostatic' + varcname(2) = 'source' + varcname(3) = 'grid' + varcname(4) = 'y-direction' + varcname(5) = 'z-direction' + varcval(1) = 'non-hydrostatic' + varcval(2) = 'FV3GFS' + varcval(3) = 'gaussian' + varcval(4) = 'north2south' + varcval(5) = 'bottom2top' + ! open the NEMSIO output file for writing + call nemsio_init(iret) + if (iret /= 0) then + write(*,*) 'Error with NEMSIO Init, iret=',iret + stop + end if + call nemsio_open(anlfile, trim(anal_file), 'write', iret=iret, & + modelname="FV3GFS", gdatatype="bin4", & + idate=jdate, nfhour=nfhour, nfminute=nfminute, & + nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + dimx=nlon,dimy=nlat,dimz=nlev,nrec=nrecs, & + nmeta=8, ntrac=9, ncldt=5, idvc=2, idsl=1, & ! see below + idvm=1, idrt=4, nsoil=4, jcap=-9999,& ! hard coded to match FV3GFS history files + nmetavari=3, nmetavarr=0, nmetavarl=0, nmetavarc=5, & ! more hard coded vars + nmetaaryi=0, nmetaaryr=0, nmetaaryl=0, nmetaaryc=0, & + extrameta=.true., varival=varival, variname=variname, & + varcname=varcname, varcval=varcval,& + nframe=0, recname=recname, reclevtyp=reclevtyp, & + reclev=reclev, lat=lats, lon=lons, vcoord=vcoord) + if (iret /= 0) then + write(*,*) 'Error with NEMSIO Write Open, iret=',iret + stop + end if + else + ! open the netCDF file for writing and copy everything + anlncfile = create_dataset(anal_file, fcstncfile, paropen=.true.) + ! update the valid time info + allocate(fhour(1)) + fhour = 0 + call write_vardata(anlncfile, 'time', fhour) + time_units = get_time_units_from_idate(jdate6) + call write_attribute(anlncfile, 'units', time_units, 'time') + end if + + end subroutine init_write_anl + +end module init_io diff --git a/util/netcdf_io/calc_analysis.fd/main.f90 b/util/netcdf_io/calc_analysis.fd/main.f90 new file mode 100644 index 0000000000..ef383a2aa8 --- /dev/null +++ b/util/netcdf_io/calc_analysis.fd/main.f90 @@ -0,0 +1,32 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! calc_analysis +! read in: 1. netCDF FV3 increment file on gaussian grid +! 2. NEMSIO background file on gaussian grid +! write out: 1. NEMSIO analysis file +! Original: 2019-09-18 Martin - Original version +! 2019-10-24 Martin - rewrote to support netCDF background and write +! either NEMSIO or netCDF analysis output +! 2019-11-14 Martin - modified to support MPI for IAU +! 2020-01-17 Martin - parallel IO support added +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +program calc_analysis_main + use mpi + use init_calc_analysis, only: read_nml + use init_io, only: init_read_bg, init_write_anl + use inc2anl, only: gen_anl, close_files + use vars_calc_analysis, only: mype, npes + implicit none + integer :: ierr + 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_ANALYSIS', 2019, 300, 0, 'EMC') + call read_nml + call init_read_bg + call init_write_anl + call gen_anl + call close_files + if (mype==0) call w3tage('CALC_ANALYSIS') + call mpi_barrier(mpi_comm_world, ierr) + call mpi_finalize(ierr) +end program calc_analysis_main diff --git a/util/netcdf_io/calc_analysis.fd/vars_calc_analysis.f90 b/util/netcdf_io/calc_analysis.fd/vars_calc_analysis.f90 new file mode 100644 index 0000000000..770783ebb0 --- /dev/null +++ b/util/netcdf_io/calc_analysis.fd/vars_calc_analysis.f90 @@ -0,0 +1,48 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! module vars_calc_analysis +!! contains variables shared between modules/subroutines +!! for the calc_analysis utility +!! Original: 2019-09-18 martin - original module +!! 2019-09-26 martin - add support for netCDF read/write +!! 2019-10-24 martin - support NEMSIO output write +!! 2020-01-17 martin - parallel IO support added +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module vars_calc_analysis + use nemsio_module, only: nemsio_gfile + use module_fv3gfs_ncio, only: Dataset + implicit none + private + + public :: anal_file, fcst_file, incr_file + public :: idate, jdate + public :: idate6, jdate6 + public :: nfday, nfhour, nfminute, nfsecondn, nfsecondd + public :: nlon, nlat, nlev, nframe, nsoil, ntrac + public :: lats, lons, vcoord + public :: anlfile + public :: work1 + public :: nhrs_assim + public :: use_nemsio_anl + public :: fcstncfile, anlncfile, incncfile + public :: fhrs_pe + public :: fhr + public :: mype, npes + public :: levpe + + character(len=500) :: anal_file, fcst_file, incr_file + integer, dimension(7) :: idate, jdate + integer, dimension(6) :: idate6, jdate6 + integer :: nfday, nfhour, nfminute, nfsecondn, nfsecondd + integer :: nlon, nlat, nlev, nframe, nsoil, ntrac + real, allocatable, dimension(:) :: lats, lons + real, allocatable, dimension(:,:,:) :: vcoord + type(nemsio_gfile) :: anlfile + real, allocatable, dimension(:) :: work1 + integer :: nhrs_assim, fhr + logical :: use_nemsio_anl + type(Dataset) :: fcstncfile, anlncfile, incncfile + integer, dimension(7) :: fhrs_pe + integer :: mype, npes + integer, allocatable, dimension(:) :: levpe + +end module vars_calc_analysis diff --git a/util/netcdf_io/interp_inc.fd/CMakeLists.txt b/util/netcdf_io/interp_inc.fd/CMakeLists.txt new file mode 100644 index 0000000000..98abb9c90c --- /dev/null +++ b/util/netcdf_io/interp_inc.fd/CMakeLists.txt @@ -0,0 +1,13 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_NCIO_UTIL) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + + set(Util_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/interp_inc") + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + add_executable(interp_inc.x ${LOCAL_SRC} ) + set_target_properties( interp_inc.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + set_target_properties( interp_inc.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIRECTORY} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${UTIL_INC} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH}) + target_link_libraries( interp_inc.x ${W3NCO_4_LIBRARY} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${MPI_Fortran_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${ZLIB_LIBRARIES} ${CURL_LIBRARIES} ${IP_LIBRARY} ${SP_LIBRARY}) +endif() diff --git a/util/netcdf_io/interp_inc.fd/driver.f90 b/util/netcdf_io/interp_inc.fd/driver.f90 new file mode 100644 index 0000000000..e0783a008c --- /dev/null +++ b/util/netcdf_io/interp_inc.fd/driver.f90 @@ -0,0 +1,510 @@ + program interp_inc + +!--------------------------------------------------------------------- +! +! Read a gaussian atmospheric increment file in netcdf. Interpolate +! all fields to another gaussian resolution. Output the result +! in another netcdf file. +! +! Namelist variables: +! ------------------- +! lon_out - 'i' dimension of output gaussian grid +! lat_out - 'j' dimension of output gaussian grid +! lev - Number of vertical levels. Must be +! the same for the input and output grids. +! infile - Path/name of input gaussian increment +! file (netcdf) +! outfile - Path/name of output gaussian increment +! file (netcdf) +! +! 2019-10-24 Initial version. +! 2020-01-27 Martin - added in some simple MPI to speed up a bit +! +!--------------------------------------------------------------------- + + use netcdf + use mpi + + implicit none + + integer, parameter :: num_recs = 9 + character(len=128) :: outfile, infile + character(len=11) :: records(num_recs) + + integer :: i, j, mi, iret, mo, rec + integer :: lon_in, lat_in + integer :: lon_out, lat_out + integer :: lev, ilev, lev_in + integer :: ncid_in, id_var + integer :: ncid_out, error + integer :: dim_lon_out, dim_lat_out + integer :: dim_lev_out, dim_ilev_out + integer :: id_u_inc_out, id_v_inc_out + integer :: id_lon_out, id_lat_out, id_lev_out + integer :: id_pfull_out, id_ilev_out + integer :: id_hyai_out, id_hybi_out + integer :: id_delp_inc_out, id_delz_inc_out + integer :: id_t_inc_out, id_sphum_inc_out + integer :: id_liq_wat_inc_out, id_o3mr_inc_out + integer :: id_icmr_inc_out, id_dim + integer :: header_buffer_val = 16384 + integer :: kgds_in(200), kgds_out(200) + integer :: ip, ipopt(20), no + integer, allocatable :: ibi(:), ibo(:), levs(:) + + integer :: mpierr, mype, npes, mpistat(mpi_status_size) + + logical*1, allocatable :: li(:,:), lo(:,:) + + real, allocatable :: dummy_in(:,:,:) + real, allocatable :: dummy_out(:,:,:) + + real(8) :: rad2deg,dlondeg + real(8), allocatable :: latitude_in(:), longitude_in(:) + real(8), allocatable :: latitude_out(:), longitude_out(:) + real(8), allocatable :: slat(:), wlat(:) + real(8), allocatable :: rlon(:), rlat(:), crot(:), srot(:) + real(8), allocatable :: gi(:,:), gi2(:,:), go(:,:), go2(:,:), go3(:,:) + + + ! NOTE: u_inc,v_inc must be consecutive + data records /'u_inc', 'v_inc', 'delp_inc', 'delz_inc', 'T_inc', & + 'sphum_inc', 'liq_wat_inc', 'o3mr_inc', 'icmr_inc' / + + namelist /setup/ lon_out, lat_out, outfile, infile, lev + + +!----------------------------------------------------------------- +! MPI initialization +call mpi_init(mpierr) +call mpi_comm_rank(mpi_comm_world, mype, mpierr) +call mpi_comm_size(mpi_comm_world, npes, mpierr) +!----------------------------------------------------------------- + +!----------------------------------------------------------------- +! Open and create output file records. These will be filled +! with data below. +!----------------------------------------------------------------- + + if (mype == 0) call w3tagb('INTERP_INC', 2019, 100, 0, 'EMC') + + if (mype == 0) print*,'- READ SETUP NAMELIST' + open (43, file="./fort.43") + read (43, nml=setup, iostat=error) + if (error /= 0) then + print*,"- FATAL ERROR READING NAMELIST. ISTAT IS: ", error + stop 44 + endif + close (43) + + if (mype == 0) print*,"- WILL INTERPOLATE TO GAUSSIAN GRID OF DIMENSION ",lon_out, lat_out + +! Set constants + rad2deg = 180.0_8 / (4.0_8 * atan(1.0_8)) + dlondeg = 360.0_8 / real(lon_out,8) + + ilev=lev+1 + + call mpi_barrier(mpi_comm_world, mpierr) + if (mype == 0) then + print*,'- OPEN OUTPUT FILE: ', trim(outfile) + + error = nf90_create(outfile, cmode=IOR(NF90_CLOBBER,NF90_NETCDF4), ncid=ncid_out) + call netcdf_err(error, 'CREATING FILE='//trim(outfile) ) + + error = nf90_def_dim(ncid_out, 'lon', lon_out, dim_lon_out) + call netcdf_err(error, 'defining dimension lon for file='//trim(outfile) ) + + error = nf90_def_dim(ncid_out, 'lat', lat_out, dim_lat_out) + call netcdf_err(error, 'defining dimension lat for file='//trim(outfile) ) + + error = nf90_def_dim(ncid_out, 'lev', lev, dim_lev_out) + call netcdf_err(error, 'defining dimension lev for file='//trim(outfile) ) + + error = nf90_def_dim(ncid_out, 'ilev', ilev, dim_ilev_out) + call netcdf_err(error, 'defining dimension ilev for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'lon', nf90_double, (/dim_lon_out/), id_lon_out) + call netcdf_err(error, 'defining variable lon for file='//trim(outfile) ) + + error = nf90_put_att(ncid_out, id_lon_out, "units", "degrees_east") + call netcdf_err(error, 'define lon attribute for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'lat', nf90_double, (/dim_lat_out/), id_lat_out) + call netcdf_err(error, 'defining varable lat for file='//trim(outfile) ) + + error = nf90_put_att(ncid_out, id_lat_out, "units", "degrees_north") + call netcdf_err(error, 'defining lat att for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'lev', nf90_float, (/dim_lev_out/), id_lev_out) + call netcdf_err(error, 'defining variable lev for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'pfull', nf90_float, (/dim_lev_out/), id_pfull_out) + call netcdf_err(error, 'defining variable pfull for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'ilev', nf90_float, (/dim_ilev_out/), id_ilev_out) + call netcdf_err(error, 'defining variable ilev for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'hyai', nf90_float, (/dim_ilev_out/), id_hyai_out) + call netcdf_err(error, 'defining variable hyai for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'hybi', nf90_float, (/dim_ilev_out/), id_hybi_out) + call netcdf_err(error, 'defining variable hybi for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'u_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_u_inc_out) + call netcdf_err(error, 'defining variable u_inc for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'v_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_v_inc_out) + call netcdf_err(error, 'defining variable v_inc for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'delp_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_delp_inc_out) + call netcdf_err(error, 'defining variable delp_inc for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'delz_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_delz_inc_out) + call netcdf_err(error, 'defining variable delz_inc for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'T_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_t_inc_out) + call netcdf_err(error, 'defining variable t_inc for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'sphum_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_sphum_inc_out) + call netcdf_err(error, 'defining variable sphum_inc for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'liq_wat_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_liq_wat_inc_out) + call netcdf_err(error, 'defining variable liq_wat_inc for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'o3mr_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_o3mr_inc_out) + call netcdf_err(error, 'defining variable o3mr_inc for file='//trim(outfile) ) + + error = nf90_def_var(ncid_out, 'icmr_inc', nf90_float, (/dim_lon_out,dim_lat_out,dim_lev_out/), id_icmr_inc_out) + call netcdf_err(error, 'defining variable icmr_inc for file='//trim(outfile) ) + + error = nf90_put_att(ncid_out, nf90_global, 'source', 'GSI') + call netcdf_err(error, 'defining source attribute for file='//trim(outfile) ) + + error = nf90_put_att(ncid_out, nf90_global, 'comment', 'interpolated global analysis increment') + call netcdf_err(error, 'defining comment attribute for file='//trim(outfile) ) + + error = nf90_enddef(ncid_out, header_buffer_val, 4,0,4) + call netcdf_err(error, 'end meta define for file='//trim(outfile) ) + end if + +!----------------------------------------------------------------- +! Compute latitude and longitude of output grid. +!----------------------------------------------------------------- + + allocate(latitude_out(lat_out)) + allocate(slat(lat_out)) + allocate(wlat(lat_out)) + + call splat(4, lat_out, slat, wlat) + do j = 1, lat_out + latitude_out(j) = -( 90.0_8 - (acos(slat(j))* rad2deg) ) + enddo + deallocate(slat, wlat) + +!print*,'lat out ',latitude_out(1), latitude_out(lat_out) + + allocate(longitude_out(lon_out)) + do i = 1, lon_out + longitude_out(i) = real(i-1,8) * dlondeg + enddo + +!print*,'lon out ',longitude_out(1), longitude_out(lon_out) + +!----------------------------------------------------------------- +! Compute grib 1 grid description section for output gaussian +! grid. The GDS is required for ipolates. +!----------------------------------------------------------------- + + kgds_out = 0 + kgds_out(1) = 4 ! oct 6 - type of grid (gaussian) + kgds_out(2) = lon_out ! oct 7-8 - # pts on latitude circle + kgds_out(3) = lat_out ! oct 9-10 - # pts on longitude circle + kgds_out(4) = nint(latitude_out(1)*1000.0_8) ! oct 11-13 - lat of origin + kgds_out(5) = 0 ! oct 14-16 - lon of origin + kgds_out(6) = 128 ! oct 17 - resolution flag + kgds_out(7) = nint(latitude_out(lat_out)*1000.0_8) ! oct 18-20 - lat of extreme pt + kgds_out(8) = nint(longitude_out(lon_out)*1000.0_8) ! oct 21-23 - lon of extreme pt + kgds_out(9) = nint((360.0_8 / real(lon_out,8))*1000.0_8) ! oct 24-25 - long increment + kgds_out(10) = lat_out / 2 ! oct 26-27 - number of circles pole to equator + kgds_out(11) = 64 ! oct 28 - scan mode + kgds_out(12) = 255 ! oct 29 - reserved + kgds_out(19) = 0 ! oct 4 - # vert coordinate parameters + kgds_out(20) = 255 ! oct 5 - not used set to 255 (missing) + +!print*,'kgds out ',kgds_out(1:20) + +!---------------------------------------------------- +! Open and read input file +!---------------------------------------------------- + + if (mype == 0) print*,'- OPEN INPUT FILE: ', trim(infile) + + error = nf90_open(trim(infile), ior(nf90_nowrite, nf90_mpiio), & + comm=mpi_comm_world, info = mpi_info_null, ncid=ncid_in) + call netcdf_err(error, 'opening file='//trim(infile) ) + + error = nf90_inq_dimid(ncid_in, 'lon', id_dim) + call netcdf_err(error, 'inquiring lon dimension for file='//trim(infile) ) + error = nf90_inquire_dimension(ncid_in, id_dim, len=lon_in) + call netcdf_err(error, 'reading lon dimension for file='//trim(infile) ) + allocate(longitude_in(lon_in)) + error = nf90_get_var(ncid_in, id_dim, longitude_in) + call netcdf_err(error, 'reading longitude_in for file='//trim(infile) ) + +!print*,'lon of input file is ',lon_in +!print*,'lon in ',longitude_in(1), longitude_in(lon_in) + + error = nf90_inq_dimid(ncid_in, 'lat', id_dim) + call netcdf_err(error, 'inquiring lat dimension for file='//trim(infile) ) + error = nf90_inquire_dimension(ncid_in, id_dim, len=lat_in) + call netcdf_err(error, 'reading lat dimension for file='//trim(infile) ) + allocate(latitude_in(lat_in)) + error = nf90_get_var(ncid_in, id_dim, latitude_in) + call netcdf_err(error, 'reading latitude_in for file='//trim(infile) ) + +!print*,'lat of input file is ',lat_in +!print*,'lat in ',latitude_in(1), latitude_in(lat_in) + + error = nf90_inq_dimid(ncid_in, 'lev', id_dim) + call netcdf_err(error, 'inquiring lev dimension for file='//trim(infile) ) + error = nf90_inquire_dimension(ncid_in, id_dim, len=lev_in) + call netcdf_err(error, 'reading lev dimension for file='//trim(infile) ) + +!print*,'lev of input file is ',lev_in + +!----------------------------------------------------------------- +! Compute grib 1 grid description section for input gaussian +! grid. +!----------------------------------------------------------------- + + kgds_in = 0 + kgds_in(1) = 4 ! oct 6 - type of grid (gaussian) + kgds_in(2) = lon_in ! oct 7-8 - # pts on latitude circle + kgds_in(3) = lat_in ! oct 9-10 - # pts on longitude circle + kgds_in(4) = nint(latitude_in(1)*1000.0_8) ! oct 11-13 - lat of origin + kgds_in(5) = 0 ! oct 14-16 - lon of origin + kgds_in(6) = 128 ! oct 17 - resolution flag + kgds_in(7) = nint(latitude_in(lat_in)*1000.0_8) ! oct 18-20 - lat of extreme pt + kgds_in(8) = nint(longitude_in(lon_in)*1000.0_8) ! oct 21-23 - lon of extreme pt + kgds_in(9) = nint((360.0_8 / real(lon_in,8))*1000.0_8) ! oct 24-25 - long increment + kgds_in(10) = lat_in / 2 ! oct 26-27 - number of circles pole to equator + kgds_in(11) = 64 ! oct 28 - scan mode + kgds_in(12) = 255 ! oct 29 - reserved + kgds_in(19) = 0 ! oct 4 - # vert coordinate parameters + kgds_in(20) = 255 ! oct 5 - not used set to 255 (missing) + +!print*,'kgds in ',kgds_in(1:20) + + if (lev /= lev_in) then + print*,'- FATAL ERROR: input and output levels dont match: ',lev_in, lev + stop 56 + endif + +!----------------------------------------------------------------- +! Loop over each record, then interpolate using ipolates. +! Interpolated data is then written to output file. +!----------------------------------------------------------------- + + mi = lon_in * lat_in + mo = lon_out * lat_out + allocate(dummy_out(lon_out,lat_out,lev)) + allocate(dummy_in(lon_in, lat_in, lev)) + allocate(ibi(lev)) + allocate(li(mi,lev)) + allocate(gi(mi,lev)) + allocate(gi2(mi,lev)) + allocate(rlat(mo),crot(mo)) + crot = 0; srot = 0 + allocate(rlon(mo),srot(mo)) + allocate(ibo(lev)) + allocate(lo(mo,lev)) + allocate(go(mo,lev)) + allocate(go2(mo,lev)) + allocate(go3(mo,lev)) + + call mpi_barrier(mpi_comm_world, mpierr) + do rec = 1, num_recs + + ! skip v_inc (done with u_inc, which comes first) + if (trim(records(rec)) .eq. 'v_inc') cycle + + if (mype == rec) then + print*,'- PROCESS RECORD: ', trim(records(rec)) + + error = nf90_inq_varid(ncid_in, trim(records(rec)), id_var) + call netcdf_err(error, 'inquiring ' // trim(records(rec)) // ' id for file='//trim(infile) ) + error = nf90_get_var(ncid_in, id_var, dummy_in) + call netcdf_err(error, 'reading ' // trim(records(rec)) // ' for file='//trim(infile) ) + + + ip = 0 ! bilinear + ipopt = 0 + ibi = 0 + li = 0 + gi = 0.0_8 + rlat = 0.0_8 + rlon = 0.0_8 + ibo = 0 + lo = 0 + go = 0.0_8 + gi = reshape (dummy_in, (/mi, lev/)) + + if (trim(records(rec)) .eq. 'u_inc') then + ! do u_inc,v_inc at the same time + error = nf90_inq_varid(ncid_in, 'v_inc', id_var) + call netcdf_err(error, 'inquiring v_inc id for file='//trim(infile) ) + error = nf90_get_var(ncid_in, id_var, dummy_in) + call netcdf_err(error, 'reading v_inc for file='//trim(infile) ) + gi2 = reshape (dummy_in, (/mi, lev/)) + call ipolatev(ip, ipopt, kgds_in, kgds_out, mi, mo,& + lev, ibi, li, gi, gi2, & + no, rlat, rlon, crot, srot, ibo, lo, & + go, go3, iret) + if (iret /= 0) then + print*,'FATAL ERROR in ipolatev, iret: ',iret + stop 76 + endif + if (no /= mo) then + print*,'FATAL ERROR: ipolatev returned wrong number of pts ',no + stop 77 + endif + call mpi_send(go(1,1), size(go), mpi_double_precision, & + 0, 1000+rec, mpi_comm_world, mpierr) + call mpi_send(go3(1,1), size(go3), mpi_double_precision, & + 0, 2000+rec, mpi_comm_world, mpierr) + else + call ipolates(ip, ipopt, kgds_in, kgds_out, mi, mo, & + lev, ibi, li, gi, no, rlat, rlon, ibo, & + lo, go, iret) + if (iret /= 0) then + print*,'FATAL ERROR in ipolates, iret: ',iret + stop 76 + endif + if (no /= mo) then + print*,'FATAL ERROR: ipolates returned wrong number of pts ',no + stop 77 + endif + !dummy_out = reshape(go, (/lon_out,lat_out,lev/)) + !print *, lon_out, lat_out, lev, 'send' + call mpi_send(go(1,1), size(go), mpi_double_precision, & + 0, 1000+rec, mpi_comm_world, mpierr) + endif + else if (mype == 0) then + !print *, lon_out, lat_out, lev, 'recv' + call mpi_recv(go2(1,1), size(go2), mpi_double_precision, & + rec, 1000+rec, mpi_comm_world, mpistat, mpierr) + dummy_out = reshape(go2, (/lon_out,lat_out,lev/)) + error = nf90_inq_varid(ncid_out, trim(records(rec)), id_var) + call netcdf_err(error, 'inquiring ' // trim(records(rec)) // ' id for file='//trim(outfile) ) + error = nf90_put_var(ncid_out, id_var, dummy_out) + call netcdf_err(error, 'writing ' // trim(records(rec)) // ' for file='//trim(outfile) ) + if (trim(records(rec)) .eq. 'u_inc') then + ! process v_inc also. + call mpi_recv(go2(1,1), size(go2), mpi_double_precision, & + rec, 2000+rec, mpi_comm_world, mpistat, mpierr) + dummy_out = reshape(go2, (/lon_out,lat_out,lev/)) + error = nf90_inq_varid(ncid_out, 'v_inc', id_var) + call netcdf_err(error, 'inquiring v_inc id for file='//trim(outfile) ) + error = nf90_put_var(ncid_out, id_var, dummy_out) + call netcdf_err(error, 'writing v_inc for file='//trim(outfile) ) + endif + endif + enddo ! records + + error = nf90_close(ncid_in) + call mpi_barrier(mpi_comm_world, mpierr) + + deallocate(dummy_out) + deallocate(dummy_in) + deallocate(ibi) + deallocate(li) + deallocate(gi,gi2) + deallocate(rlat, rlon, ibo, lo, go, go2, go3, crot, srot) + +!------------------------------------------------------------------ +! Update remaining output file records according to Cory's sample. +!------------------------------------------------------------------ + + if (mype == 0) then + print*,"- WRITE OUTPUT FILE: ", trim(outfile) + + ! lev + + allocate(levs(lev)) + do j = 1, lev + levs(j) = j + enddo + + error = nf90_put_var(ncid_out, id_lev_out, levs) + call netcdf_err(error, 'writing levs for file='//trim(outfile) ) + + ! pfull + + error = nf90_put_var(ncid_out, id_pfull_out, levs) + call netcdf_err(error, 'writing pfull for file='//trim(outfile) ) + + deallocate (levs) + allocate (levs(ilev)) + do j = 1, ilev + levs(j) = j + enddo + + ! ilev + + error = nf90_put_var(ncid_out, id_ilev_out, levs) + call netcdf_err(error, 'writing ilev for file='//trim(outfile) ) + + ! hyai + + error = nf90_put_var(ncid_out, id_hyai_out, levs) + call netcdf_err(error, 'writing hyai for file='//trim(outfile) ) + + ! hybi + + error = nf90_put_var(ncid_out, id_hybi_out, levs) + call netcdf_err(error, 'writing hybi for file='//trim(outfile) ) + + ! latitude + + error = nf90_put_var(ncid_out, id_lat_out, latitude_out) + call netcdf_err(error, 'writing latitude for file='//trim(outfile) ) + + ! longitude + + error = nf90_put_var(ncid_out, id_lon_out, longitude_out) + call netcdf_err(error, 'writing longitude for file='//trim(outfile) ) + + deallocate(levs) + + error = nf90_close(ncid_out) + end if + + call mpi_barrier(mpi_comm_world, mpierr) + if (mype == 0) print*,'- NORMAL TERMINATION' + + if (mype == 0) call w3tage('INTERP_INC') + call mpi_barrier(mpi_comm_world, mpierr) + call mpi_finalize(mpierr) + + end program interp_inc + + subroutine netcdf_err( err, string ) + + use netcdf + + implicit none + integer, intent(in) :: err + character(len=*), intent(in) :: string + character(len=256) :: errmsg + + if( err.EQ.NF90_NOERR )return + errmsg = NF90_STRERROR(err) + print*,'' + print*,'FATAL ERROR: ', trim(string), ': ', trim(errmsg) + print*,'STOP.' + stop 999 + + return + end subroutine netcdf_err + From c489ff438ef0b9a8c10f7da0420f37b3bf602df1 Mon Sep 17 00:00:00 2001 From: Michael Lueken Date: Thu, 28 May 2020 16:54:50 +0000 Subject: [PATCH 2/5] master: Update fix/rev2 with fix/DA_GFSv16 following the latest merge. --- fix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fix b/fix index 543c84b44d..f0f7447ff0 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 543c84b44d6e87df2231988a55e0d2b25b3aa042 +Subproject commit f0f7447ff01d07e7d9b6efe017a62e26541751cb From d1082a1f4d020e707869cee88ff083bc57e801c8 Mon Sep 17 00:00:00 2001 From: "edward.safford" Date: Thu, 11 Jun 2020 16:40:32 +0000 Subject: [PATCH 3/5] GitHub Issue NOAA-EMC/GSI #3. Port RadMon to Hera. --- util/Radiance_Monitor/get_hostname.pl | 6 +- .../driver/test_jgdas_verfrad.sh | 86 ------------------ ...ad_theia.sh => test_jgdas_verfrad_hera.sh} | 39 +++----- .../driver/test_jgdas_verfrad_wcoss_d.sh | 6 +- .../fix/gdas_radmon_base.tar | Bin 0 -> 440320 bytes .../gdas_radmon.v3.0.0/jobs/JGDAS_VERFRAD | 16 +++- .../scripts/exgdas_vrfyrad.sh.ecf | 4 +- .../ush/radmon_verf_angle.sh | 5 - .../ush/radmon_verf_bcoef.sh | 6 -- .../ush/radmon_verf_bcor.sh | 7 -- util/Radiance_Monitor/parm/RadMon_config | 48 +++------- 11 files changed, 43 insertions(+), 180 deletions(-) delete mode 100755 util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad.sh rename util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/{test_jgdas_verfrad_theia.sh => test_jgdas_verfrad_hera.sh} (53%) create mode 100644 util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_base.tar diff --git a/util/Radiance_Monitor/get_hostname.pl b/util/Radiance_Monitor/get_hostname.pl index ac3d971fcb..fed558afc8 100755 --- a/util/Radiance_Monitor/get_hostname.pl +++ b/util/Radiance_Monitor/get_hostname.pl @@ -17,13 +17,12 @@ my $my_os = "export MY_OS=$arch"; # - # Determine if installation is on WCOSS, Theia, or Zeus. + # Determine if installation is on cray, wcoss_d, or hera # 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 = ""; @@ -32,7 +31,6 @@ # 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 ); diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad.sh b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad.sh deleted file mode 100755 index 10ceb0465a..0000000000 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad.sh +++ /dev/null @@ -1,86 +0,0 @@ -#!/bin/ksh - -#BSUB -o gdas_verfrad.o%J -#BSUB -e gdas_verfrad.o%J -#BSUB -J gdas_verfrad -#BSUB -q dev_shared -#BSUB -n 1 -#BSUB -R affinity[core] -#BSUB -M 4000 -#BSUB -W 00:20 -#BSUB -a poe -#BSUB -P GFS-T2O - -set -x - -#export PDATE=2019061700 # binary radstat -export PDATE=2018110206 # netcdf radstat - -############################################################# -# 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_verfrad.${cyc} -export pid=${pid:-$$} -export jobid=${job}.${pid} -export envir=para -export DATAROOT=/gpfs/td2/emc/da/noscrub/${LOGNAME}/test_data -export COMROOT=/ptmpd1/$LOGNAME/com - -if [[ ! -d ${COMROOT}/logs/jlogfiles ]]; then - mkdir -p ${COMROOT}/logs/jlogfiles -fi - - -############################################################# -# Specify versions -############################################################# -export gdas_ver=v15.0.0 -export global_shared_ver=v15.0.0 -export gdas_radmon_ver=v3.0.0 -export radmon_shared_ver=v3.0.0 - - -############################################################# -# 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 - -module list - - -############################################################# -# WCOSS environment settings -############################################################# -export POE=YES - - -############################################################# -# Set user specific variables -############################################################# -export RADMON_SUFFIX=testrad -export NWTEST=/gpfs/td2/emc/da/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor/nwprod - -export HOMEgdas=${NWTEST}/gdas_radmon.${gdas_radmon_ver} -export HOMEgfs=${HOMEgdas} -export FIXgdas=${FIXgdas:-$HOMEgfs/fix} - -export JOBGLOBAL=${HOMEgdas}/jobs -export HOMEradmon=${NWTEST}/radmon_shared.${radmon_shared_ver} -export COM_IN=${DATAROOT} -export TANKverf=${COMROOT}/${RADMON_SUFFIX} - -export parm_file=${HOMEgdas}/parm/gdas_radmon.parm - -############################################################# -# Execute job -############################################################# -$JOBGLOBAL/JGDAS_VERFRAD - -exit - diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_theia.sh b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_hera.sh similarity index 53% rename from util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_theia.sh rename to util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_hera.sh index fcd354e00b..14afa518ac 100755 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_theia.sh +++ b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_hera.sh @@ -10,8 +10,11 @@ set -x +export MY_MACHINE=hera + #export PDATE=${PDATE:-2018091712} #binary export PDATE=${PDATE:-2018110206} #NetCDF + ############################################################# # Specify whether the run is production or development ############################################################# @@ -21,8 +24,8 @@ export job=gdas_verfrad.${cyc} export pid=${pid:-$$} export jobid=${job}.${pid} export envir=para -export DATAROOT=${DATAROOT:-/scratch4/NCEPDEV/da/noscrub/Edward.Safford/test_data} -export COMROOT=${COMROOT:-/scratch4/NCEPDEV/stmp3/$LOGNAME/com} +export DATAROOT=${DATAROOT:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/test_data} +export COMROOT=${COMROOT:-/scratch2/NCEPDEV/stmp3/${LOGNAME}/com} ############################################################# @@ -34,21 +37,12 @@ export gdas_radmon_ver=v3.0.0 export radmon_shared_ver=v3.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 RADMON_SUFFIX=${RADMON_SUFFIX:-testrad} -#export NWTEST=${NWTEST:-/scratch4/NCEPDEV/da/noscrub/${LOGNAME}/gfs_q3fy17} -export NWTEST=${NWTEST:-/scratch4/NCEPDEV/da/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor/nwprod} +export NWTEST=${NWTEST:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/GSI/util/Radiance_Monitor/nwprod} export HOMEgdas=${HOMEgdas:-${NWTEST}/gdas_radmon.${gdas_radmon_ver}} export HOMEgfs=$HOMEgdas @@ -59,28 +53,19 @@ export HOMEradmon=${HOMEradmon:-${NWTEST}/radmon_shared.${radmon_shared_ver}} export COM_IN=${COM_IN:-${DATAROOT}} export TANKverf=${TANKverf:-${COMROOT}/${RADMON_SUFFIX}} -export SUB=${SUB:-/apps/torque/default/bin/qsub} -export NDATE=${NDATE:-ndate} +export SUB=${SUB:-/apps/slurm/default/bin/sbatch} +export NDATE=${NDATE:-/home/Edward.Safford/bin/ndate} export parm_file=${HOMEgdas}/parm/gdas_radmon.parm -####################################################################### -# 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_VERFRAD exit diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh index 97d841806e..51ddcb8817 100755 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh +++ b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh @@ -25,9 +25,7 @@ export job=gdas_verfrad.${cyc} export pid=${pid:-$$} export jobid=${job}.${pid} export envir=prod -#export DATAROOT=/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/test_data -#export DATAROOT=/gpfs/dell3/ptmp/emc.glopara/ROTDIRS/v16rt0 -export DATAROOT=/gpfs/dell1/nco/ops/com/gfs/prod +export DATAROOT=/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/test_data export COMROOT=/gpfs/dell2/ptmp/${LOGNAME} if [[ ! -d ${COMROOT}/logs/jlogfiles ]]; then @@ -75,7 +73,7 @@ if [[ -d ${DATA} ]]; then fi export jlogfile=${COMROOT}/logs/jlogfiles/${RADMON_SUFFIX}_jlog -export NWTEST=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor/nwprod +export NWTEST=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/GSI/util/Radiance_Monitor/nwprod export HOMEgdas=${NWTEST}/gdas_radmon.${gdas_radmon_ver} export HOMEgfs=${HOMEgdas} diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_base.tar b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_base.tar new file mode 100644 index 0000000000000000000000000000000000000000..4e3ac88fe9bf3ff93dc7078ebb36020f231df3cc GIT binary patch literal 440320 zcmeFaS+?BBk*>?%63Yb!tAg^~1F6 z^FEHta_k?*X&H~>!!Uj)cy71-$LGI){4@+7e*fctfBf|0<3B$B^wVEI{dl`19sFsW zp1=I}|7Q4@31DbH^Ek6C6Khkyotpn1rvFn<4AcF;e|KHiL+hHq{?Z|L`O@iMbhd?P zzC$!D=XgB!*#Mo#^|3AETCQ5A>kz;?)Lqtjp6z%T#>ccQ=enKw>glmu=R7ax?|(P) z7|xE%c3kC&9G=U%PU+$nq9y-2{RNC)@Ydf8NA~stNr;)3@qCQ?mO$iiz8?EJm$x3K zV|1M8z2=(@=P|mp-L`{ml;3rH%-b|x*Aqlf@_(Dw$8i}_=7Tq_>cDiJ4uRflVT;}%+R)sW za?k0po@nyt;tzBSVG&k0D9k<^S7ie7kB!vvF3S2 zpFaQLobW&fn3&rwuKhlZ|WzF=_uG+i(@7v%;u`P}|`Om7cPKz(o zah;E4H%x2QT-#53tzR|t*f}foY1PJM+Ar7s*O5)Ul-u1x!!4w3o~~_AFWaozWX~!P z-B$O@E)(wZ3$Fh1#VtfnJo_BShnq2j=xDkeZdNV1y#;^5QSzsn7aY=nMNfwJ32SdW zrps-%b>49?7oNtaj+y9)P|;-SA#&~7_i@>6_rt4jnE398%Fm*lv~*-7Tp;=d`}sT3 z(OkS00w{(y;^C_T5mIE)su}7CLOoasQz?ny-8?q1baa=>kCuI(aT}%glQweB)4n** zUS>tP++(w%^sJfHHLGUaA>AW{#%4aTKoE62I{;;ef#$1b-4i#w)Bd`k;-tH6$K_QhL)yuzqm+lzZYq#x@$4)ujkRh?sJ^lT;V@5e!L( z4L>pubGj-7Kk~O1NCiiFYa@8!=r~W4HQ>ng>VhNJDJ5yK?2*gmYOr}O9J%H{U+ab> zPj4?AU9xhXa1>6@HtQ+Ssu>BFReL?pcF#~8h>V2eKopK=FQ$vd!BNMvUr*Vq@xCxP zG7p^qilO`U+70DMFjcJYh3MKT)dFFmz{tuL>nK)mHmj`VkISqyJ|dRS1)Q zbS-$p3fH|J_!-FEbQ~@Fc;?07b-cCg^)P#w-$nxH$A z!4a!ivsq8x(~c94R{VIDctXY}q_WNO)+9PwSku|o6gt}RT4wdMS+(ro&MRBA+WElu zZGdXkmU(Yh?e1Y`zuX|&_VX}5FJ9rIBkFOxOb9@qpdZIWw{ z7J_U!MjS1fAc!5oO6F`ZHaId}CS9dfI|%)>`jILmZu-&P6M>YtK{TQg8T`NwQR3J) zh!&_}w|J%iv-;NWG zSP9Zhbh7~*5!QxKTtA{Di^>;QIOl^%P8K;WM8^Aci-e;IInm&VyjDs*Y)4M#J#Q4v z<3>ktqhmECo%JS|4H_yPk-B2{lE$_n1`~iSL`El&a6G4* zL`Qqav)2p7x*!;B1W5~B8Xd7{=u=f2!A2;hK`lhK&GpEHBk5!{|CrtJfblyWouc%H zjuPcJ9C9bRZtH^V#|(fOI7AC!n_NtzC6*M~^2IGg#%T9xt0SuINg%^&RUn>?c|J4k^c0#&-P4pEL^2s&&bGGyp`R_*oL zi0umjl<0`SDwJ(%)ga0x{#SM^tF}7-NjQR7Z#cqAn2ti(@KSPD;82Dm68zBL3Qd9| zIQWqRGYyXH*9K7l9N8{%93cf*a9d1*252LdXLogM2ZFT45eyI>S$M?;9bw>Bjcpze zG^WZSS8_g{tRst37>O3234IQrFTd~)XM7@NPhO#Xp*g%BWua@?paVyua z$OY)=u8m;E`zj_nV$IH_&?c5B!v0M8keMIxrjxnvwAWCNvH{#e)bZ>9t5$Yu#Sz<+ zL`x%OmLO?X={)PoUba=rt9H-ORQ3F7h73}KoyB(Yy>{X$t-GIHf##AB+Ty6=*#qQ{ zm2K{V0i_R3u%V;-UV|CjqzEO~Vo@1>vXMboB1495B5Gkr zvY%~>4jWlx6b=|B(GY#NCmcbkhOHAfiwo&SoIsmY46w;HG5lzSofEH;70{AoE@~6GY^w&e&wWYPcoIWy@#bN0j}) z0a4Gh5$0&tzWX=i*0M?|O&_f08y#(=_1+*_(Ok@OIaqya^v=5b(M1q*29eaiBdZlH zj*Ri>vVi0(wn zJary$4O$loT=2Lxp3zNv>vSfx{<3lxhoHX@t3u-{C$svz@$3O#3w*?sE(%)7_Su~uU73trUgJviy_a`Ck1+2C>&t&5?Hz;# zZ?<`tfasz{M`kQ7M7E0rX~q%RGtjS&`K*$=$70k*pN<=4D-pF)HZB6RyXh=xt8n`R z6itO6vD~CjqK0Px(F7?8fPw0;g~&FQ9uGvXmut@Z3Pg1Ipsv>yQ`&eyCs$TIxrCi0 zl=!M)6W;mJPL=Of-g0{2Z6ef=u#nai7ah)8JxYg25eO*}a*Ly$XVVhsYW$F(8Lr|C z6K8J+QMClpGkF4Wi2O|Yj$l}Ahu74gEgdM$`KNe~f86_?I8 z9SE)Q%SP~at9GMoAlh(;m{4TZ@FwBd^S#E_I!)>cM_4My)9$xjR3RdMj_=DM;+L2- z<*)!y>1eCgQd%|Sta~ERYQ&$CM+?LN?@VyZc$*-CRb=z6(h10JgTs^PJ`ui6F{iWF2uJzloGt{P;|JLM+=5ro8f9kvkJ@;F3SikBO~L+I4S zn=TJTi6K@TAz`d-82#_N_JEr?)8na{MVX8Niw%MeM2w4cGkRh{AWYdCxF z5aGqYK}0VIHdlToIO3W3ek(-Sa;6LlB1H$&W^W;~^>BzT)?xCHk|-NFU~o&xz2OMo zYYUMC!)^{bC|liLM)&#S=|vSNPXr?5FnYJ1+(J}#YI>`LBSnXhKIscs_=-TUnm^`D z2azmbVE5Pk{sXAHDx z>sIaV^JiM6U!5n^#OTO{p5m|$HsR@5s=wQ9R;8$G$j(G$-`$wSjJf=|6`suaO? zxUU)t*=?`k3_+6VA)+H3wFf?=%8yV#i~@jYB-`S7)r=dbTj(~_m*T58aR*<;I&z^x zn6-n5dfR6A&r}{@-0NnUvau94#}R^-_?7c)BoMCVgpw9VM#AY9x(#d{4CF2TqS4 z(hr|-#A~+@(F_vji0^*l+W2Rxq}^~to1c+YlV>Df+(Kl?(Bl(jA8c^=gpT>}hOD>g z7Xu~DcN|FvZdQ#VVw|5&N5Tn4qtlVn4I3#!$@Uv`WF)M|$JqUbi~BB(RE87XC0N5`^H6(ZacB%$Q9K*Z_eNn`U} zq{|9KCmATl$`eGqYQD=`5ZyF3Ir(9+`D*%>VIJYFbsSA3otc0FBINFsRmv7ewmcQ0 zPSVw zd4;l}3@2sne%!&vN8f;`;gELlS4KEIna^xTC zzAcW7X7zp9YY?xyXGBNnRsWnH)vOJz3;YLJT7*53V;rM<@{F=-1SMb$>t0rk9vx&$ zp}2Re<^Nh{Ew~&vuA|BeM+bBfi^Cuud{VeG!<{2d-Nit)JizpzC zbGEi+Cy`l|554|tXa6>wzMc?f_2=?x;%#G78Hq8}Ei?tWmetHx_< zN~y(lz!7==q^o2A3AVHEz_+7}vIMra0BBb&9MAUU5u_sfS(MXcXu=B?_?%AjA?n%T zs8(yF-9+CAO6c>&${M3C+j2%z8sj;x6-T6Sk)NQ8TO8SX==%f_6>vmF4Rr)ssT6k` zirnTKL<@=kw^c*pc>Nt5lJFmO&c00K?7-3VsKk$0(9%hug{bG*GqnubrukQik-Ks#tc}Ju!^KbYk&l=CS#m>I%vmMjhPap z?Djm{#f3pc5_j8&otz8GQd}FM@XBM?T6+yy>mVX!vd|{13;qM?IUNzjMPD(9XtY6s zO3#lxXk8!*uxhp*aUe3r69*z=JO!dbT>$8oVqcR8r_L%y|Ku~>DVyxaI~`GoZE3=y zY`XAF4IRPIEoo1AwInM&Wkh9C7dU))ZU8#!cy<7Y!tre5X0~brl?*UJX9`N~MK3f= zPEGF&@gr5J+~_D})t9$~j!5jKEZO-HL!i;<(z8&z(FD=pT-VB9Q@D`-BmE6QN1k~t zkYYe&>T7|BdRpc0c(1Wl(@lLw5%sk9{zodFy{{V9id7Y}YEooU9b{6hNefoiSXvLQ z8kX2|m5*iKrK@7#C>+mrsa{s?_58?m%s{JVoF)#AqVa5$%(PzlPlUZjFT-#U6|FbH zCFm$9Voi%jH3&!)7Eq|$sAdku5# z$qxw^&F9nK7^@ad&!&DW9F9z(7GN<}t@Dk%T#C>!<-Tg_5<_1<58%+ik!}xG{mDqX zTCt+Nws-ZkIMgw73y-670aiJsW>ts8nPl+;*&-@RN@SyZB{n_(tgQM~@eyBg)RG z`zSnFS}l5QU*AvZlw&B$s)gg(UYRCTiKbFC%iG;hn}yuPabGZrq`Y||h!x!^ptkQ;P4Pr|wEig&5y0>g3E_zTOvbgo3K1o{<+ZsT zlucz;>U#{aQ_gnLIHxK1Cn);Vi`DztCb%4;wxUkGg1;RieCEvV%5O=JAT=nq9^SM--uQX2T6YGx9X1WbfjLaMw@_urau~HoKomB^I*JtLEJS z--5{f+bMQLf41F}borsUlT{rO55zN02drk*Eb!ezRH(3BHA?k-nS>+aJ6~9}4kFrn zm}eBEP}N0gl&u=gkx)nKs?qR{#x{C%3z2b}vTCo_*u3#tfk-?X9C;ul(~-%}udEvD zLaz+?Xb~l#C3y>QNROTn(7Q_! zb!_tJx*kFgILjfB_6ZPYStbI~)aBD%-|2`@O(}J4A$sE3^r&ilZ0dl5&)u$i?p$%7 zmrW3qH*&33%^?Z5XAlTMGkJ){dJfUfT;{(25nNNtRX*a`q}5PoXu^`<7B$hO5jba4 zqxdG4jf?PBPm3f~i?)0}$u-8tG+h}ewD<1dl51+ZmB4Rt)bnh%132%<6pm+m@-1q(&D$=LBs%2sz~wLeKW*bOI^{MB(&o z&*6=OBlA?pfhZi$cCSYq9EIcA-q$P)j>6SJ&gSVAiehj`%a#rVQ8=D$v9Lfm3dghi zI>^^s*(P0`n10qq7Uz%02uiA=gis+g8@Ig~C zX=cp7G!0(TzdA*)_Wc8ib=0RaYhl?xFvf>us1L*VU7+c1`j5|l|M+PbKK%a2|Ni*t z$H#ws{OPB^e)_Syh{HdP)AN`A{@)Ch01`t;e@JU$tw`dt1UtUHr*_sXi)5?&Pa}9X z$%S!vVt5j$H4g_-G#!xo(Qr75rUR146%I$84mccSJ<=M*P)Bu?YQ*hO&6O-SPdtPX zQnx()h2znB{ZU&*hXwk$SSp-SQfVQTaX_9vhb2+E+yyZ-; z9utM@v@&i>l3jV(k*@z_(d8$#5OsEY#t}Ku8MQ;g(dC(;;K*0$%~hlS3B6nLkChim zuZ)@qOEJaj`Iq2`B*2o(*+SIu>_SIYNS7cYlig7EwN)dBb@u^v^i(0klXtRJn@BeF z$sX#d!hGJRImLawM}~+-Lk*6UdS4E|3K3If7^j-AX4Pm=Mx~%bL^eBVp7|^gX&zlJ z$Zc_CB&^G{g3wW#DVcu;j_Axq{%tvY1EMAeo$;9TtYS)527xwHLPF|Z#!@gCl1yD@ zDj9%efU2fOw{9Uag3Ptydf2PpAgh0W{^Q^O`nTVGFB3pY{x|FY+lc;8`NQ(A z|Nl?WMA82X0cacZ`BnP=KqVb>iky8?|HG`<)%ZKTvTm{jVS4YYL=h)r$uc1H(PB0+ zx#z})7C8?Myr|3E}t8SO>#O$Uo(vPRQKZ5myzyHF~0tBa$c zig{M$b-)obq_Le1M|4tIyblz&rErH?!FDhGt4}XWw)F%@uBxaT)=s<4d@tVJ|Qt^{7aY`bbkF#2Ba#w()RdN@yXPTNMKY}BV4Wup|` z>QGp7M)4NBGoP0KrjEi^jrN6g@-ccF1z61E)RS9?O!?6FFO;`>eEFExs>2u%_4+@R zf2tKWUj}4>HQ>cW6ma@(7pBopZ*?eY7J6Jo&(S1SDVDAlF{ym_iZG^GqSK*h3Kz|) z`KHqMiH>N#hWcfji-}t59cnw0p0U2$Geo%+oqnyo#&|7hi}`Q?BD`ugcn)=t@qo=t zSM*v96V=5nM1sOT8KM;%q*68zL7hhbK;)gB-h}9)wQU|k2xFlcCvQ_r^BBCzY~X_a z5qROZeKq6oH20QOLnn2l2uBqCREVZjKBRZZ5LKxn9KpI)7eSi8c1VAIHk&ANe(nEr|w>>)A=sSqv5R&Q`1%BGgt)|OrfH(MLZc1lk?o6_pS^l(r;Xs)_p z0c40IoYdUdQO26mrZQ1%OGozh1`(2$J9&Ft)Humq<62KrgjT>Nc@snw8IM*Uja&mo zND9LdqLq@_LifnE5!*j+t^e~sp(*|Ed`7GP|L~nc0KZ88-{-9VA0LKy|Nr-=xtsp~ zgSIiBU#0)QJiF=L|L?{_SM%C%?q2^7uxgzw2>_948`={{)c_EgB#i@6r~eOFo0@NI zx-H`!BP5V5P~5KMs!=+J7LP|_1MPL{8M&*x@Ain5jreXO%mk*eM6VF zl>My#pA%kZQ;X=@OxJJIM+YEs2r@)>{hwyzbe$;o#B!h+Hx1%UC&3v&1M@<;Qt~iu z^TiEBZ|MJ*dg>c_(a{Rs)*CL+J)zUv?!AogdEj;~c*k-;C&CYH5aHa=1a2WkDi!7_ z{)iq&t|RKAtlP3`m$y{FaweAHrZ??T+*?sr%~vr!gm^JC33M}Qk~GDqjk@b?G@P06 zSmd*)=0x|=e0A93$S6eLXNd5SU~uc05B>wJHisKBaR@R*^sH#<2n69^&%ebRrEdI{ zj<9T)nq2l0t0vpK?>qmN{?9-FJoEXcoTpF1;T{rNB)i?1AtJ`pK!g{Ic_jr4JJuft zer@rxEzIVy$}TLDeL)5%ifwW9tpC&Vq0UoDI0CE!AcWE3Xm|fa>J0=+)}@%T+5;D@ zoXe_h8mK{wncB?+2M`k&bn6zP@;>Q_Joi-`^84#a|68BX>i_>4LH|Ftr2kLryZ-+_ zL320#|33@o_*MGf7-ekU62ei3mJ+Cw^*k}RP&Dz4(f!{lK(VbAU- zK@iEoo^Q>?2q{`f>agKT&;I`zSwiR_{|x6lN1IDGx@+Au03s4De+3bfW?+4V)8Q2- zxQ#-CyhW;VRv^`W_|r;|Hy3-h5Scn82=s0n^CIv`8v9f?9;P*z<^n{H6Ws;b>JX-9 zUd*1c7zw^Y28N&#m1buqTC8jprD4W4D?lsk_ zu?P&CafmMTTyh@`qUB)jlg=hpywp*5NVcM;tbkannI` z7hH_)Sxykq9dNWYMz@()hS<2ajVGBXNr4wllHd@H@${G$BHL8@KH&)6s+k!eh>m$N z?d}bToUQ~Bsx4mV@;bZ=o&7jA91#d)UXbhm#FT03nFykV$Vj+>2p!K0)dUgFUt3!s zatPkS5!o|iaWhJ{Wn*bw3?elTL;KdF1U}=CE;x%08i?M||LJ;5kWSa}frshn3pl#3 zn(}*WjdN_ZXsA*-YL7Y+Gygo+trFj zV-l@()rc@NB_ZEhRvX4b-(l@7{h#?3MC=-f7P^j=!;PTE9ipmzXVPE*k4=v_=nKAS zvpF5nln(x35D_Xk37YD#T{U}_zArdh8vnm28@6UwF>$Eh{WtwziELPE83fsp#Ep_% zW7!F8B4}xZZU6!gL6Uy=o8>Ej5=5k%@k}pwM$BPr8;6k;x#5V+xdtL+>A~)|{XHS0 z3BFlI5@*@%^n*>$Vy`JbxeTFu_y7OPs$$mv|H8<`@0R|reE)CG|G`zD{Qq@bJ`C^v z|9^Q|zxjtn|AzqbzDj?8o&JyBK*psd#SS&xhc17`CmF4P{#uwU z`ad0DY3%B32vxGp|AGIa>sn{eRI& z#Ws@$fcyqtg4_7BGWIy!QH`@}sfEZyy)F~yCMg$)jNyYL^Z_zd@?C}t#j?c_4|L5k zJ#)p;XcF@zdquP6q_-JFq)}Ih6makR&_3t?C?HN2f~j*1uT`YpakSi5ZKqPlq+Nn& zM1WcsZ6pBkfBN=kh;S@&L>7QABC0q^40_oXN47lrKI4dowyUP5zeXA0=n0~m)usv- zB&=@6?H+hVF@!vv4L#CLxU7ooNa~UL{-Ibo`Pcatuk&s-P?++euY{w6MzQFmCh~a) zkng>E)gRqfNti~}y{#I9Drq)bevCJh6a`4xmWe^V2xQkuh~<+3kPh2bGlFR#BDdXJ zyyMmcy{2nXMbtxdI)tJlR)Iw;&qV(t8HYp(g9s~}q^iP6xLA4g{j^}L9D!0k1xIKh zmN>x331*gJHrW+lg9zOgV?AH3slGE4DXP^5$|zaLXO(EPZ_mn!I^cSd}}a@$@Bs3*&#>} zG2YE&OX5m1vchyKMd~GCr6s|N;M{2ZlX)yTWS%DKdk<0JS_uHj05Ti#x4OcQ`;4jT zCLIKkOS23S)Ehr><5x0$w5!(1lGp1bz5YL(l*kdMG1P$` znKnk*C;+a@>b*3oti=)YO7Lb?4M6n*m9nwF$TM->mLilBpIc8yrfukZoum%*l9yb^ zeApbsdt8@djDy?Of(YB&Aru`Qn%!*ut?{;#+75uW*9b?jq^>2Mn1o|iEZbGHO{K>J zQGiu5WQ2jpC|>~ORlBg~;biFxMYgU7#h*r2j32t~HAu{lwQ8C#35&`E)frxA(^V{a{^w()N9qIcju?;YLsiDx58_Iqw|6j;Aq$nOqhD=?x&fAVg-{J^Ywqjd)2xhw~ zu%c}Wtk|NT~ zE$RfPIx#>j)+SdF0rST6rmTfjIo-E~sN>m45$MQ^J(8rwU1t!?n|xa$%lO20 z5)~dHph{dxf66DR-{rq`l6S0fk4aU7AXO`#i}K5}`FcvYby4K}_ZFYY^f6LoX^nhTzKEh zd>{mJz8BOW1?5?{HS0&02}i6mck)Ipq-7H!v1d>ne5Y)5^BZN8#x_FA`I++DGEA^$ zw&A%~9cMm^?S)Gc6-b9IjtYj;Rh$f5C z8$XgkXOu3=hKhE)#R=oeZAUNK4%fDoHAnm}pGA{It0a?Ohs~-z>Hn1evYYItf(ReJ zX*L5M54Rh27d*wTH3=eAMN-QOWh+MtGq1@cQL0PjkTeQ_L8gmah!SCCs1s#_BXw;m z$`yK>iUFJ%yn&+|ha?0-GD)HAg_j{JQuVf#Xej}T{4@}{VwFDkwkhY+Re9Cmki|~m zOUjes8ov84^3-gVGL8=CPifUy2(N@yGCMCgRsEk#mZtv?7h0&Z#Zk|*F_F;tjmZt9 zWD?f&IMUU`Xfs6j{D1r(yiIva)N3N3EvPA!BsJPqNF}!$^ zc}xE{=9Dg&8m^S&hy7Z-N9}u>ENSt8qa+S+mL_61d8-Xyxf04DVN%!s(InNPY%ALK zNq#V?Jd>v=khnRbO6%z@M7=D*y`vkOI;VVF!s5m!i7DQ^Te#C5LU+iX(z6q(q_B zXU4da2SH9lLP~-NfKWd52BcFxiGq{_YP#v}qnUv6KW;#N_u6bl6HVZx%b`)M3 z1PMnFk{u^mlJY~#8k0vx;uve5K}f{FD-;}Xh(`7X9T~wi5Fuhcc|s7awa|sa6knwb zk$Pb?RvR{(XNo~#N@lHj8~FQ4Z!Hu6M06)Y{_4psjynB+pvD2;v6+JOBq2iueM>*% z!wqf_k!0Lx06YZJEzKc8Ih%{Fh|SbzgfDtgzLjva@_$czt<(PpOjinQEs#OTgn&uY zNfLZ$bLpmfFDXSL_52W0*?Wg-hd`>-hU7zbA(bPf6x;4sF>o={#46zL*gEOr z7Dr_-HV{!Fg!!Lus$~L67HJs}OC64I_cu7g|A2B^cFT%ZtRzw=Wz<~A$n8kzb758W zq!yx{XHzqdW6KOLf`OFUke*rqqcMc4-^^qx=SVj$JlIXt`*I$|um;YebvxYvav z)wt2cwTGzZ**s$=mDL0=rZj}$dkqgvhoilrBNd#{YRii2l_N!Y(&A!{mT@~g(E!9Q zmm92y$lhMx3xUL%8~uV31TybDc0N$QbHfoaT&JrfMbfgAb&-7B6@zdPXt9J1qDSfC z8B+(*t%G*edY-*0|A2;5x{i{~pblFc8SfK>Y1LLJ1x2esOg#Wh+tnqqgKlz-RKEry9IK>K zU{2>}B8-TS;_l;+`=QUVYFVhT1mH+Tq)*X5_r^33iH{hd>=eOg%z#z9Q8rS|AxsY; z|Cp-B{5ldwIBkq)ykKk{h6#B$!N$ompP!|jw57f3lXL*3sZCe z!Wk3(?KCAJJEjCxF)@>g{aphf#_y!qv~RbnYh!U7z7DN7-@E#EJ<~P)-W*Ya89ip2$CF?Fvwk<^x zc&qX=iLWTN)*O(4K*^L>?#n-=2I@VI+=Zo^6o@FdahrtVIGio6TB<>o?X3(E&CB>A zgTOPfBQZ7|A_zJAZ25|_bWg!Vu#2&NNOXOIsQfxzRUlenZT2;oRR;at6EjvOlA?CL}1F*{-^s3Y%!lz(0M!8r@l6xYpBZ#j?`S=i(?ORZg$3k9Al8V0kOkhXSg0u_~ug01oH}hGE90X1#^adi^sp*N@ zBS1vd$X!{|YH8?al)XUY27&H!hlqzDY2lI?{_IDBm@^2lR`S7dnm9x_;-34FxGtuf zWQd@n+SQ60brSk*Kcm3atdR`Sy&nmJ_P|4F5UBtf|CNJ)-;Ji4zq*oF4KNi&VVR*Oy-&(QX_PgOm0C~T^ng4q?VH+-x zcv1Ob)=Eh8$0jvFjP|FDAUniZ5u;2ZRd>PAX?QpL98-}PTfQN2TePHOcFj%7F0~!` ztRyb+wS?OBd-KsvRit zc{ei?2*DPe1&t8!`9@EEgHyK4|Dyi?-Tu%0Kj-6p|Npi-{q4Km_Wzgq|Nnyhk1nH_ zswj>RC4_hbs|}Eo5`F)pGT(NaR1HrcL%6?-1<0!+l^ZidMF6k`}k@}Tn#i@nJ9<9r? z|6vhW*j|FbORFD+k6$#IZ z-ap;{f1z^h`y~L1-4lNQXY;@B`+v&y|Htya|KHxRzwNhW|3d(og45r({QtjT|EHL` zHCGz2D^*Ks?0`J?yZpy2YH3?FfZoGg@*mk(Ye`i$>E1Z@|3t7mJ3QLm_O$=;PAkq^ zUJ(}~DJ$mpOxlh?kaim}emj=5Rid$5`J6%ilVfGO4bzi(U~VbVl7#A=wB1{X`u$IW zYn!>Pj6`}A+f_7Tb)4uf!~^d8pO6FPLiu&TE;uE6ZxE?jF$^T1)&2*-(vj?$cC!5c z3to^Q`+rXPztqOQ@Bio3`t85*{crnIWb-TczxUQh(vjC6Y&Oo|4vc zB927j2^nqWndC{~%_3%M5Haeq_1rRk17}#e_zn60pPzpI{JWn%fBK#^0AG~Kw%XGOv-ZQo9Ws7dViKcb)3ZElg^N+c)D zG3c(AI?(pmn$5DYpn;DiMLB5*|9xKcKLDPlg}*@~cY3QOqff}^C`>R3ooJpkpScBnXr*IPhk zB;OM~%V#MMphT3OEIMp)Wb2{tW8kROWVGNUpc1e$mm=*osp32>qR;MEVCP0hxCiTA zBQKMnU)e46Heow~6yIxj*S!2f2o+T(_S4|VxPwrXq`!*K;YVdZ(@9cYrObu^BA$7J zh|EwoGGh)krMaU{AYJwcIL{Wxy}SV1l=XmMneuZuDr(V>U!rDHx+ zr^;t*e3YW?q&DhQfe5EgeQh=q9_YH)NZD|wQqt(~BNcpW{ud(Usj}rc{*M-mi_8|2 z<``t@RH1?z)vsDxwSkdH1F-T;WfG&vE+r-@h$xD(jAiIZi8xPotu3-%I>zpI9lAio z?q`u294R*un>|4c%%l{VWHmavQ8voFx5W}=A#2uEp*m98#0O5?wEEEdBnD-pvE zCAQg|c1Q-Q`hVFW{GF`QY_a9<^w&JP=^M8E>*?qz{~u!=)7sMaSXGMu=z3V*K`hNU zV#blUSIZ$uNHSSTi*6d*;mLBjMv4q&GWlNYHMDN(T6L&-M|_u(i@%)olyUiZZ6qRycVq4 zA>4^lo^ry(m;4e5ziEcVh{D_d4XD)*y zd|LQn?5x_9k}_q7MCc~M>^f|5WHhVqL*U3>KmZ9Mab?84r`9PGQ2B}JJZJIa8~;f- zA|t!ivoQ%tM=V4rI^u3s*po;|46c#=3;Qx1HaKz;E)cz*XM5D6Km-=ZjAd68q#(RS zM`i7m^NP;f=-D)KGuuRTq@6_*tNdeZ5z5hWrX63g*GO|fjm&4^M`V;!=d8mPM@GW> zJ_a2<@oc3JH&!I`PvvmHspmXo+^Lw=9q1gaU_ma@Gk6vg<4im0V!Gf z6-Vm1^<-r`2^WY0?6oJJO(qT{yT&-x1x)2o0+^3d86YFy9}--xEkXu4RW;?FYL!6s zgY|1=ui?eSSjo2n_Y?tve;u}TWRKSOA@-WBssJiu zxmVR8DPkphQOSY)M`S*kAIo-LMfbnlHotccoz!cmBX5gg(U#*Y|FLVAnuH9SkGQ;BR^92xH` z5WRk{xzSM|8W?rNJlh)cC#Mg2ZgAtsyk*&Anz*Ml@gqWLrL~A^Bk=9u(sG_n_D*Z@ z;@Y9W(f6$&;NxA-bP$7%O!Fxafg_AmZ-h6fJ3KteWDO3gTU-_VZC?=|XDz3c*IN@KF0dbPW_2!kWz4hbb%e~M<9Lgo$%*er!x zu4&5C(c*}5RL^cnbVTHfI7CJ;*o2Up30n{){dZl5q(G5yeL`qMNA3cRgQK2jlco&M zcC|^7nzIH~HADP{qi#}ztPQ4^IF4xY({yT*xm(&Z2%!|u6NX3^w>UE17Y9eZo=u)5 zyP*0ZsXHQ(*>o25pSd zP^nd_d0ILO$Fof*t~kQVRPV6-nq(m2aKqjxhp3P;*IZuH99(95On0#4h14Q$C0Jg^h77)7^Y!xs~pvEqP3?u)%RZJ z*+i%;fJxv`oujO96D0y)5?zb+C|!(yjUZ&&>P{>{H79DBs4705CdMY}mEd&i- zT=p|;jjjlVP6)>75y1sHyn`& zO6^?XD5^P^iR*dnFmMeW%J%}H8oQBi-Rw29_R>``aMbf`oJC~!c^fpvAkip|XR8@z zOGhBo=_=8YVoR1iL*BAFs8&BDng6(#8ag5>_0)gF{lY?03>+DAE)ZeFDp+lSLL$o~ zcQN`Yt*Qdewc1c?k5cYDJc;u|JyQy$P~lDEOWGG2&sIwW&z5Ab(XkZ`Nw;q4C>+mr z4O)OQ6pm+`E+aq_j&OvaCVIC|vXN-e{{d*LKVN@e=Fcs40Ugii8d>ZL+{ zq4R9=$te9RyBkdv`Xnhr7q>VveO2Fw*lV6uTp*&^7=B2SeRa%dPR)@$bAl=a=RbNc z4LC6Vl=d1bA}CEiReMjcOPd7WYpO)HUOtj*STWh{(%{IrS-M9I9Q8aKN2A*NnzGAy zZg{r)bjZu%~9M>PO;T z#hcgSC>+oBAdy~5??#%ZLfMWKdh8>7O!iZyE0nmshB9=+(Lo9>)`)JFeEzuPXn<#X zjTkMV??PqJ5eg}I(xokq!trd^pap5h5s4vKRXXNFCK?*0qYOvK9Y@`C2GWUP(&fi^ z3=Wbjo4rQ&BN`FpJA)(IOX1SiVT+@1JlniE3GRd=3Op2<%`ZYHFys$=!VbIHLu3Nn z=!m}5Ou%!Vjc;3$%jk$W6WL8g>VYG4sWLvU!I9N17(}m+uQ|a8B;kk@_7pozAo3Nd zG$;d3R&;?j{-gI&e9Vr;acJtH!oK`tbqFLQ+&X=MY=v!YuTgoBGQRq~=Hfy(0ipmn zGJ+`(>8;7^H_@cBN=^AN9Ff*`J0V7LI3|A44e0Je$Zh9zr88Q~_M97FAS6sqZbl7oLy?N63E0zmw&d?nW#d z_qICL7(c=XfG1KrnvXUnN=42rXmMn`PZvelYZwj!rF;avCc3Fhp?xJB;kvg&Fkp0( zaa8>PdTkA*b0;QM6r_mamNXopo?_(|Dq~}=OvdcxT205$BV*vmI8A|Q015QbtBJHk zk|=d_l&K22(T`}xcC%^em?D>V#wfN3JeprSj#L$G+zK4Q&&!a)N=KzJLcT)~9NDIF z9O2+61JVhHyjr>q`XRNUcN`t=2M`^RdyJ-C?y0%sI3;U*P4#uo(ZLZ8JnPI-a02C6 zMNaxA1|1m(bsVwQ#50U>szaql#FTeHrM$_0#*Ezg(E^GrM~l5i0Ucd^jgBZXB3@Vc zKR8mS*M7n;Lc#GBWv`im?>M5miY_B2$kf4uX$E$cst#K^QqKcBPW*^W8t-1MmX*{9 z*4ZpXC$WhgM+{~`D|fplqsHrl(_siYvf2)VNChJ5UTthjeMPa(osMwZ8&1SS)Uv^j zg(J2Sd$s&nzfAU<(UHp6Fh(*mq(fpHW&j#~WWE!F=;b;jP!@>wkGKww5YlQrDT_Yl z4+eD_KVo>y4M+5lx%vE27#Rmvu2%jL4U22uD^#IIbf39lML=Du2b?GjnCCqhSRJDQZK zmX2(jmsJZuM}~|75k@S#tC4F;<1eEVxJ234hLeON=)#V58uLP_YPy-45K|yR+Mwsv z;!&f6u2C*}Hj`QUoKdvY{Oj~L1|1oN2qf(hO>=9e*Q!qh%@f_7)bng&LpL1JiK>)0 z2uI{s5N|7VBnCuZ$?Co%Fk*$JEgc!ZDiFP%j@)}@I8sLeO#;v{AGQ`oZ+?M@L2M}2 zB-rSf4@VeWrW=E!B*rR^$d##dB)NuL&A2kY5gh*PJ(p{+BSsSBJ8NT#x!bRP?C=&90)tLnx^@QcS?@en?l-) zTY)3k9@>~TOcCSon(hD*T8}6(X`=m>Tf?EoSY!#>@FS1q#lewr z<2Vq7L8iqL4O%*7(^mJzD0&C<+UGh_&D8Y?XT2r z#GK+v-N#8_JWicTPFiWWO-nsL*#NF*!Df+MYCrGmh-J44lc%* zqr+zRdseZ&k3rdnj5rW=zL5ZQ)alvGq@;}})dRvAAIdb*A8bEEN1b()hco)_SC3xL zc_m|*G*v2LO^UGD+bj*Ga~9W5Lq~lbqT*3q%7AXUYBYf=yP9keycp5SzNK8rg(?EX{wBtHJs$YFIIS!cO-@5W7-fI<1Gy z1oDE(+S6gXY8C(~5CvGZj%N>K2`K(+fPy13D=KBDekYld^B!|nf#~&g`Lxf+|cDhdPunK7a#H?rTIAQd8pIZ+OzV?IDMV|bgUNw(Ha z(q5_Kc-6CMn?-kwVsQbHx{RKlS4$DoLCr|MGvL!O5CrJ3g(w`)wwP*yJA|HXb&>`V z9(HMsp8kB2M!-lBTSVf%_f=~=T#1fI=EcjN?nY>MVO+u9Ocz5tD&vIG#i;YBth%^e zwQxM!Nm!7^Sha9G+X<%NXi!=z?FCJ-R?;eg8sGi78Dl!Dwa5N;x=N%$f#PVT_{uh< z$Z)Fsh~z4~p?Xxhm}K(OT&1C-r#eW*Ao-t+0DY8O1KTj2h3YehAVHK=%PUjIY(Z@@dOd@TV7jQh=n|Uv!j6s z9(}A8BBn%;N1{iii`Aq(1JL3q9MASBwZIOs`;ET}pdb*1z}8UqNh-_J?(cXu5D{naFrpx$ z2E;wObRu&I5=32YjoP*{TsXZS`PmfBPMB5WYa;;3dLeB=PK^_iQki`%_s+g#sA zplq~Gfl@v(AQGRpPYj5n`9>%)F$D2%3>=xBA;4llWO_y%h@$aq{LMm6`DovXXRE1n z`AXUd{#2v?XAW5{N*Fv@^{OQ(Od94-lRZ>4)9Fk#AW!O;VkQBfeIQ$!f zj>7Tmz7F!`9xd~O7_#Mz}OU&&6G6L<;i2~BFCJ+X(Jp^cARNbBRJG7 zLwa_S{SzG$uq>Ri!AD`y4Q0F0p_|0Oks%`vMB#Y0cmIfkqmE|>*!|&nwwu#s)sSm6 zoM3Q(j`?W!Q}olebR?~!ZeZ-s|)9ik; zWb}26-5;(Fk`&H_o%|;Rhjc|K&Z>pu*;b94mMzArh10V=Dinu~j1|U#$hdKVD0ypC zoSX#qR|I!*3zvTo^A2B z1V9MNwmw^dAPUE`-NRVu==J)MlW-h}!s*!-r3ggX;q>fqb&xcpPV1Hbgy4`K{tUC% zOa{fFZ1?BI!I3!}<3MC;M;wU4@obNq$H7rJp550$zFr&gGK?^*7OoDGc^X1a`Gk;b zeI4ZM>BzE95|(1%C>+nW9-D!16wWu|MWI4c3_1$u8?id7ICSJ$GhtROTpi^6Tn9;9 zfr%DIUK~+xZW)fmAiI3XJd&m6LozbKizvy6!n;K`#2j?IXev%4vN|G)Iw{hp(q?Zw zTHcGYtQtNxjqmW1EsiLj^dWlB5Y?Qm`>sm!E#7HC6&FlN=E(AL&{6;ovAq z_EYdAd@+#<)!9``1|^VwXthF`xRgo{^aIH?1}LRqwvPFrS<}JWtO+WMXarB?K|ZMw zCyc6aPXmRUC#6zpks8gvuY(+@6Qv)Yt4*4_ey*M%Md6tD%hp|12B}Nb=4YllL&icC z%^!$PO2;h8fyScbN7h-lM*O;*FnCX zXIpVObAdbX0z%vD$sU&lKpti>{x_I z6%B3ciX33~BU@>}OpTLazCk#V8Qfj>d5yN(z&} z;iLa%BocDM!)^@UQr8fpBNQ&z(6shYg4305fR4t5Tz4kV6wfbKBtz3o`h=X`QGo1t z3R?Occ7zZ&vQGp$s&hI7RSbxt`Lk;;fjBsd#m`18mu&&c`l%j!7Zu=4QVQd5@TRzLhGyYc&oXnYI!KqK;<|3{Ixmn4^wiOmtOqA2SM^+xgP6HrkiADJxLA%Wd0)g? zHOo2)1d(}$1X76IAFd9P=80*&@}C$uGK)UWs)gg(;p!llaCMMNxH`x(K)dX>5PL0L z9pqyDz!R2Y;3%A)9c~^Zp4mdxVR-f$j%SCfgQPQUv{egN2f2i+gIvPZK`tJU4YT{b zekTq@;q+{ag(V&kLehq-gIwId6o-z&@$7JQkW08aNNNPrF3W#H?6tlQ^5xlwOSn47 z#go;;?0!$6jRR3QJ=+udL3@J0Gz}~2q_Y-4sr=s2f28a zLl}N^gyY%a>L8bJ^B@La1>6@_Qq>*a1@Pa zuioMz3XV$S2!X>Vg5AG{tAkv<3N#LmqUDXOK2tdkj-u(=R1FF_P zTDUq$M(l>eQ8a({YW-~E$hC0uAeliPj*i0d>~M9ERL@3RwQzNiYm_?35AUDHM-lv~IKlOouH* z(R>BG$kVC`NA8N!szHUORe+$Oh=6OX>i1}pLMqSCwi08 z-Gtucj=_`RMxG}@3pxfA<>Jj2N6~x*Oclv5kp7BkvF?+0ars(wbgrHqe|DYs*!^I% zp`&Z3XJ?@!`oQkjPVY_MYrFPd;WyCHM(4duu?>!T|E?gK*|x?MwEJlSZ}fj|oA-|{ ztF~)SN`{{|IX1*;dFH`(Kj}qXDSM+ewJ{bt4qnp;H_>lfhzuF}KI3RUcADJkm=D9& zAJ=AWYKL=83^74aAWH2D^Tn{3iFWqZ!Tx%zBOS4)3eisI8>?vpN7q5K`F^kU{#|f1 z({$SlJs?e*ntCP5$$xj0y{cWRLo_lH-s&+~wSymAOI@{%QCtNFK*aR;DZ6u99NF^d zo&`tC3PSTU22wx7RZP~LYwg%raFiMXIYcXjX6+vtu645a#)_j8E^T=dj0B();rt9y z$Fqf_eP&*OK}09w4RS4q=LXr|cmLW-k!>CUqFjA~h3#aff#Zl71*4q>M=WA#+tT95 zXjYE|M=$rw4aU*#U551XETGI-0hHsSo+BX+BD)t9iA2WxPl#ni3Hq=L z73Ph2hcvwx+-qvJ5qL6O*)=wF){O?a&W~VhOi@X1kCJ;FbWqD;uEkNuvjfnP?V^gK z1GenxUTmGm##pobUc-t0b*H0o(--#I8`B+6>w0vmZ5-z($I*ctGdT>7W(<>Dz|rC; z9MA6kyMtKB`S1o0iH>NLZ#cqxaKq7b9j(R&&mIrUI2O;|*qnth;Mok>+)dYlXQK&j z*{Eo76pm;2{$1f{ZZvl$`I71l&AuzhrVM9kQF5=+GI8A|Qn8ph(>?M_mXXwZ|`%y+V>T10gZO5@(Dvs7` zM?Wg}JQ$A41&yAKUNGCN2xEsnzRY+F^mbe3z(#l@5|#z}eAV?zF<^VsAB z@$PgqgT#uXZCp_di-v=q%~;EEJ}S>XuBFZgIo4z53*EZKkv&@9$JlF~Zv;BpF^F!m zf26Cu0OoUuKehT1`lXn7K8u!!u`-*h2X74?Vl-{X5i?U7KLxWcAhX20S{&JW=$iHo6%8*&|}0akn!8% zD4d?%_qhW{IO-UZm0u*`2tj4kc0eUJIvUTb)gc*?vU*H?!|dCccUbkKX}K<&l7ew} zj_aDeFb$5}QB+p#^*W^adJ;-R_Seb$!QBfODbi&Fxo1?9!|ymk0cz+7ZRk9V$KeY@ zw&O4|I)YzsK8;WYFwUmz{BCg+j%T~IT2^g9C!8MqNl3$^C6>%rVlg@N`xj>7S5w=x82+G{gRxS89+UL)jV z{0IZA<45CtuQ8})vkX5xPk7wmZ;m5yHrl=9*d=h28_BeEWXn?^dObffzp4PrI2z@_ zHr<%LwmxV+WpMAy-FplNcDhRODi}7--gLKNA;yCTesNzdb_o2fDhdRMQ95;TgCnzK z(mhzU066OPY<%eKt}6QpGC&zdN9?+resnW-rcJ-cvS3_0A@xRiXa zofj;;;2RtfBtgT}lUh0o$FtpdH5?uC>Tl))D&}KHVh5UNa7w-b!)}=}x4s>ecy^sOQ-b1~#p$P2@+ByWpvR@MD+t zT6^W58qUOzWUgU<7>>w?0A=onBu+K}W`%%c>19VY#y< z;`EtGRH;6nK_L>uNy3rxlgi#pY9aO;L4*9;^`WdVvU`nZli`bQP;s;!#yEso0h zbdMM~GD}P#>D?e2!u@7cX?!a>q{oghu-x|0doi2Y`BRc>=Sw(F=M1Y(hVXob9MAgiV zj))s!U=-RU@W#k*5|V7Mkp+B>=G6nC$^(4L8*w+WAPBM7+)-2@8pv5t8k;c%6? zc6cobMQJl7I?CaGcM0*^3A18RBpj>8*am9an$yIA(!HhH;K<&-Ks4b0!RPP(qe&dRq%3m@yylK02&cu-fluu;yPq=`$$qEvY=Zx6E=dMH z&=K1jrBeqjj>75Lru7QY%(D?b4-C`v1z+I>7%$6~8Ho3HI9fe}T(5mVcdn#!DcaCA zx{nQMpp5c-Yk2m!VbZ2WYH<{fXZL;X23~R^{m2%Rs3Bfyzl!X}JC4X`Zs`cmBC@J* zoDFVIZuI0jq_TiL>lQjfokxKZ${HM*c9k$0Vz0TwQ6PzU@Y!Q$c~c&WVjk4An3#j3 zyByPd&3Haq99;{>h%vJrRRF#FbUH%vgFv(WU}OsBC5mlvWakS+ulJ2O<0%lKXOl4Q znlpMf`VkUer}>~~-*7~|%FV}iBKT&rxY%p_H%Ztg`wtShuubx<2Hc(K;o0~ORrj>=U?xG&>qM^CiU4lF%v zSV~cCui-A*cjNzwXDdBGx2`zCol>5qeJja%ux z*jde9gN`Vf!zj)_R!#)s{&HU}>M5Fbp-B`42np|!E^cuYjb~3*k(1sk(GhALyP)C- z4vs4Df4V$UifJpHLdfT{C{93@*b-rlVTTn)uN^qx6)krEX%^*F1lsleh)S6O*1zQ9*iA zi=${fdveXEtQt(3Y6nlVLZt*pBzP1$x-d;{_8JvvhO?|^kE8%N&&KSR@HaZz$gCkM znePRT$g@E)*I|nzqgj0)f{vc+APLDo5I=&D&vf7gs9cK*KG&-g9U-||91#q{0xog@ z*^d=Vc8%ePVB3seAm3Sv0!l@nH&T>JyCy*12nn498vP?`0U?w^xUiq8GGvF?j-0g< z8@nG4(`cOVY|h~j&-a9{VX|V$7>>XfT)Ob&WZXem34n%<%y*LR5rdA5(+DKt2th@u zs0(}9Yxt0itZ?Dq_Zn)U;Y@oCZ}vKy^9j$>LOuOl>F6S5)K>*P`@&6-h_1zv(OH4$ z<+jLVIquQQgKAuh$ov3;D|IVw|t** zbdS@Ls7A71*)9764;osc=V%dCp<2tVAIUZHBa^n;(2-S9CM3nck#Psd5iWm>F4MC~ zccebne1`)yGxxnV*Zj!Dv&nemt4sv4S`-KIxCqACNjXG5%htmWL#$heEsnzRY?tbS zG{&lhYOhILkuvS~!HIq%1Yl^=$_8Jji$U4u$1sQnMH#Kb1z*CC@EQ4>kX43Cqi3r}RHY-a z7^*>SwmDVrxX>umHo11eo!mFV#oI-;O)vZ1-yH`>9nTIxN4Bry;K&rA0?|MrBV|YK zRwCUIqtrcdm|u4~QjD_UM^rk%%*s6#%SMdV++$is;7=+dQ}H#5B>Oyn*U|-0kiBL? zJ`P0Tc(yzD3y#R#m#fwmn*<}(q**OB?f5!=L_$_eN4Prhz?R)Ye(psU`|9z2(r$L5 zM|xCp$dP1HSY0F6T%_uv5ZZ`qhjAb>9WxF@9nZ$HM?WGvO%U>tK7@2KxM{R`=SO7k z-RX#+u0^A1ex)R=YWGv1L$Ih=KMD{)M}541a$QW1k3mNr&wjmJ^Sr`1IO=#dbc6$Y zcNZ>nbR3>3JCL{5(NV3j5sM+1h6}q`6I2M`#w6R%^dlWnZmXBq#bj^M2`Eu)%a4qN zbx{a9viwc~6a*qOgW^Ec`$lMPfh)`t?!=D>+M7QkcNb~$*htlH`4MEH2!FyjwW2t) z2}8PEqr!%&zasTgy$FVXZ}+=jAP$Z?p8a}$WR(;N&!VY=(gNB5*kY>O7mu* z8sdXI!BKf@aCEOcAQJ49uGgjrh(^anD3a|##uG{QPTBN!YBI*jcqLNvgriQ+4#1C| zcs8z1W#|ZJd?fqn=wYe=UJ1vE)}C;=A154PB+?8d{gjRaGmTIQd>W28Aj0Q7n=m}x zc6%IoMUie2f{r|oCk{lm9&sQF$FnWxOehLMM}_hOL1f!J4vspW{dx}RPT4p(>Uj3+ zab#M09LnzNAcvE*RD_KQU^2vs2D`dMKP8uAl55nu-m=E%EI3h3kls)6KScdrtHmZp zPS8^~pQW~y3dGXhveA#8>L5>&iRtZUtQ?5QVsuQt0g>lNO45?FP6vSUV`U>LJJNG& zDD)zuv}k{Vh@J@9b=yJ|j%QnrM<6=tcs4z|adx0Y=EWY!fWpA>&MnU#_Btmbts14| zlsX$7QBOw>rf1fnPpX@j)6tn0S%>Yah2z<_FB04#G&WD@7f3N6GJ+`(;S3@9uvTY~ zkx93XFGc*kS|iaBiNegSN*IS9F=~z4OZTy<_MXbad{(T2ocrAWp`jzIa7kCm1`qh)BvX>n=k?PQF6~k}zZQy@Vt7T9ytiM8=$TS%Qd2 zEDlUtOy!8;7&RWT=2jYR(NJc6%ZG$fkULxUFA!1XjY(7?8W}HA!6$}`+f`3)AqvN{ zP09$+7<h!2^wrNJH{NvVq9b zNtu9^84#hk`Z`EDv?U74f7tym*R%1$g@eeraapwhIO=$I0EnXTY@bY)s3`_zn+%OZ zN6~mT=IVX-C!W2~O0s+nhoscodBm4_HhDty#-TbPs~>PkEJzX#IZPaqJ{Cj-8qeqzP&N~Mt9u5@ChlnZ#X!r^FK8p8Y+Ceh zr9edexX4_)WE~~Srjg=7@u;ia^sc3AiyqxjcDOo7>hlwJ@}Ceq+j=7=kYYd-j%Rys zTp=k2jygU2_4<+56BZn?`&C0{&dot`joL~Rb89YEZ8iTUi&eXyShx*;My}E0guWNP z`w8JT1-}#+l4PH@R^uM| z)T)K!+5J4oWQ*Y4G*cIzjepg0J>JsT?*8mi)da=6K}YA~q-$#B*|@st5Lz`h4A{Oa zLrElwv})n%AemZO@S}f1?EY|dkh9H7OPGp*qj0_v?`Rx{jym7S>$O_%{1^vE;d~=~ z9pvj*&FU87?0$>m27<_hd>G2Mo(_R<6pm+mN^hK13&*p)aeo{fh2z=og$;uvA8ir` zqHub4xH`x>Ej-Suh2z=b>L6$99j!%+VL@88Ng#;A@$7JQkj!OC>y`h6u(F@(AT=^` zpEh&hl6^>f9-D$WFv95`gQS(uEhCE7&y<9f7bNG2ki=CoqAoRbpBYr@9xbwfkEiIm zXBF!v!j~W-?bA>vh^R<20N;SfyTzuQQKJ30)f^(mUQk1uLEuf9=XBJ@gXD~ozL}oX z#6`TLWr67R_L}E|#epcCKijA#gM|K4)p%YmQ-wny8rGj~sT*sA80tvqX)Fw`i5RVAJ3#m+LhA$Xiqth+fZ+tiN`k zRWtbz2S?%bY@0w3Xw|~`M#9xWlAf5>EB^^0*Q|OY4juJ%kgw;E#_?8TF!PSfA}! zhB$e)VcPxFC)(cQwb*MrbLooC#a<)zxT%t)a}I@%<{hTzD>a8XVZYgHzRiWE7&tPB z<3MEV5eK4hdUm)vNCxX^xymO7Wp_NA(eDg=E%T58l+BtN(G{3!>)^6JNm@;@^8Kyd z&-`h_yR24b3ft5RWdBL)L-!yeX&JEBcdR52&Je`EF>n-(XD?pkBveJf5jx;~)dr^i zO4&2i(G-)`W1i_wC96vf(Gjx&Q%Os?38nYUg|S=|=!o_srGJMsHpVY;)+iSpk}tA8 zSEb0}UFdbs7&wZ?vl(t(5FQ6d(e&)ar_RU0kx_meh&rApev%}Rv)>$TH)#z_V%K>jvG%#x`S?`6~P{`aqla{qj?Id{F{lu!Rxg;9f%Ip*i zbYKQz9#&fejqThp4|VHCV+%JAatT)lx%BfOU(d5GjFRXigrp5O4{`}t2f2i+gIp{x zFAyDt)3d#rSV)So*P{8e$tg_~l>fxQQRf?ZJA?kR|mP6?>P}t2s#Q^2U%mn zap))<&ki>aatT)lNmJs?t^@70a6Eer=g$sT2T8N*Xmn(~?Bh^&xH?D%CWTwIaQ^IY zb&yNAI!K?o6=<)8-YCZ2Z4n*N%kbNEG>n+G|b&$0$ejGXq=Nqw{e4!}F z?hmJDhpU4uLp0Nx1z9!kL>q>V!qq`8UM&*`N8$8rFENONqi{UiC-lX^Q8=C*t`2hX z%Cs=67OoC*vGf3;D26uTRf%yR3dgh0aK4dnb&yNAd5}xEI>;ql9VBxW6DP`lLik3) z)j=*-IN!(>F4r&IJjliB@e*mrpzLsZc0UjD^*%N$cnP#>(frwr*bTw90p1t<-AOq~RXugrvM|Fpx>~M9EYq&bdwVwz1ddd!0 z2kAX#5}ypgv%O(foV^x~XNQ{yxrVEQT*K8tQg9zl8wpnjNw?N;I0~m{hpU5Jt;22{ zDH5&@at&7pxrVEQT*K8tuHot+>9-$)LwXy+}HKPNH_O!pZIrV)KJg^yBk&e;TLfFaQ0&8EynnxRJU^jr1&Toym6< zyml!_-a+SL5v)NW#pH%?{@o#* ze|HGy-yOpFcZYC&?uKyw-633`yCIx^cL?X-9q!8IFuW?d^Y5?E|I#;T)&Cy?*nbQh zO!nV0zuSMmbS?jt>u>ho4@H-IxBujq$jJBwtf=E#t&RL{|GkaS7Dw;)-`8>UZvTB9 zNALFES8?=i|AC^n7<|Kz-tE6{z)?7!{cit#!>Wbz*}dC;|BCMZTl^;5e}9>-?_~Q4 zMp5Lq#{Ujtfwab6$M^W(Z?U{zy+^VCAb`e?|8D>N6DHbOcwatjbcy%)-#s(n>m{$F>& z&mTYk{GHQ3zij`_8$)nM&;LA@Me)CR+27-T{}aSEv;<%#;2ZYees`?3dV80{K3vzy z7<(@uKaT5huBXYaWj_|1Y^u9VBXf-TB0qb4(6#uSt@F&x6s?ioVcYM2r=oqvXff9K z*h_xr_@Kn-+;hW|7NYn3PZ(TA=q-HN;>gxRmxa)hhtB>Ru5Dc&hqsP8Rwm~9B=tN` zx4fp_>$;}H=t`8bT-PyLM}8)?DZhL>jE=}N-F_!tTeruwmZJTldU9;EX+keBg zZ`0%Sg3V*wAIIW7WS4CpZExkhb~z8%UZY#cL={Iy8OS@Pi^f>K*G{JNS?8{Vqh-!R zU|Jl79MA6UKj>&&9-B96I<^Io?H%ozY~egQ(-Cy$EJk!R&WrU@hK{ZUaqqI9Gv~OM zocv5jV{UZX;;75nXVs*Cc)LHX+B|zj>07HN(yqIoH8UxKHgeAAIi9|1`#7}_9mjcY zi6OQSb@rd=Xnb6oxv2!vG5HK4B-3R$(OpDG8U6Bhk^aUEAak9m{ptj1}Q% zpRU|^xrHbk&%Q+;#7B_*lJ>?FB>S(!GijG?>F8)W4QGWP!LiDZp`%?4=yDvLBNR}$ zm2kwvuCy8rj{5rkylT^7s7q3$&enTNinLlSoq0}}VqQe(XqlnQ#Ua|K=`s=pqH`f! zmeipZq5^Tc2mgK3?7n=+U4FsUU%t47$d*SSrB&O{1D)Kq;IT13_wvb_X!ae49FxkH zk%Go{><3ITA5M>JW?|0JakPNKwQxXiG(+{78MF{}d3Kp+V@~Fq4r#AlUg7?=-M?HD zo2@_uUt8vd$~c2)MoMnR+koggjx`TlY9Z=)wji33t?ll=cCX$BA}Jrv`L+97egs22 zcC)4C$AntDT$LZqJME1stDvxQ%qVLi>h$biKpEWS7hL`2i(80{V6;jxDEm#Gy_(^f z=xE!$cf(t|U!IuUS|CiXY?al^~_a=+@O2Y5xIE3wk2EJEsl)w6dYwbauX&~ zHU?9EE)B^f(|+6 zkt;2Z>{+@f29Cn<>~M3Aho$4$0XSqho*iz^@nHN)TP?<3bM-Y2L>^@LO5RF$W z`=9je8_yn>5yLRUzreGna~i8h>;G@>+_EG|ZuDHwT19L?al-HJ3(yL*0G_5uj`%>0 z4tpeRU*B(LfWa+_RV)@;iP2>8FsmcN(;WeW{kX%3U#%UpH;n8yQaoU`*#@1WQ&BZP zDDEI$#22$2srd9=i@Yv5wUvYt&wd>?-*qBQLhNC4Uxd@%&a+druE&gHpude2rNiv; zoa1VZtcNM!B1eSkD-$F~SkHG&8@(fpi-izUy_$F?Ji3-{XCKU+=?ul1C$L)#{m7#M zv#T7Des;`c=VBoZ*R^gnP#P&R3DMW8lD+Rw zf?$Z4ty(VVUmKrx#rQWK!2tqDU9vYqShf?Ph=DyNlN@G~N%07ztMU;kGVJRVVI>~!=xfz**Mekw zL|u204H^A47J}X0IJ%HeWkOPjjjR(Bm7IK7PYQOF?D3pqBwLa)8@_Y3JmMLbB~{?jHSL7MT(Y-a@$Pyr@d($dGBonYmM8Ftj9)-VVu0ArPSLv@-FCks z&E{ppqZ!v^?Q(=xS?pXa3p|WyPv_~G{_v7%jZ^^1{2jSxG zuOY{C-2KGY>(Gfvkx59Wh;@k(c4D==TT$TANYNSh8Y#0C?O%DcK2d|@<~l+Gh%Tb6 z8d{io09_m@GNf^es0nxyN3S=19PD-?zAi^w5#;hn-9>Y*ZjyabWni;5h_J)3YYjZw zF2uRsnpH#bFE!#BDY8d9MaUv6Y$Ry+?@NgJzf1N_i!94@+RVw793;v2!vtP>4T6mBuVD5WwFvR-WwtItsy*~NAS6P6T9lRV4bTB+ zBSmkReau*mUH9)32@2`#L9Bb9csF`X4kBG37E~wuN`)F6H$k$$4B;paf8_;(xLYnqO(K%*Q1aX>< zl&0N|*Bc%=I2Sha>tY9hY;6NS2qf~VTmIX0v$Me-U&WfKA&y_eW@XhD6xrG-B9(>m zw^bu2@DeqY zu4~900S4Qf zSEA9U zdaM|G&(q3Nv3w>7iJIMNMmSJ(*tgeBB-!Bl{=}53H+>w_LLS-Ib|E=*lcSB#8yXZj zQt65%FyRs5>+|Ro5x%|*KcR@n5dYSbB1LbQePPw&QW!;Ok$E#sB_8>1*InMMTHuK^ zUj1XdBOHZo>$@MYn$4+TuR#zQHeDPkvTd&S3y)aZ=j4v%@#32vW*a}2WxXLJ6$ZYF zg-00nq%3ta?KO%r*#6zB#eF30Q$K}A)RzGkdKoFQZLar45tz-L%&aOlB}$e`m9z=kd>cM`x;!@3@Cax~i6Cx$0l z#CAWP(evas^)66EUODLgt0uGhLyE3)$)4C~)7C2xghwW2QaRHC&vfg^qXDyjKr*ivJ+5bNYf~i zTMY(!WOSe8y_^5=AQ0=Cwa5`Z>Rpadg609s8riXk9gnE%rz)n)5w(BwTP2J6ydtRW z{)MPo$7~{4I2X3I_|U%F3q|Mb6c)+GkN1;`p@?ll@WH$zED`*IzWZ?_KwLdJ%F&3~ z$4(e;_EJ((y?7MnH^Za#ru!-R^w)(V!Vu0;_8O%>M6{hE;%y;*gu)?H;`>&V@nfDr zc_D;6_=-fvZ3|K+_ry*$x?#JoQsEJk8{(>ASg#oB=OnKhW!U9?8Rub~YuM9v?258bUHbjtD=Q z6%LP%`M~hjtpktTpw|0k)u=nijx`00ToPmR>XP}S>NeK>k9b8*RL3K-bBK2RRC08Z87Yg@c|^>O7a{#XOZ>fewKpve|{e zxN2sL>9QQFX3S_5JuqWc>uE5x&1Bb6*!6ooREuIf(f7g#bj{l|?Yf#h0e2VT-?PWq za46TqtUv93B1koL7kTuC*|Xxop6@5JfW_t+KN^W{5iOR;SFupE6FN1I3~yM)iEE$; zG_o&CL`!O~I*gGbV}|iap@iql^$+GEgc+l;}LeCy{-sJs@QZ6dX3mTwzeZA zxpmG7s{9s@4zi?0kRwI59!}B8GdoDrgeUIW+M<o zYkP^OsL;2X)sZ6m_D&IBQaR}QMII}88=&9l#uaf2bQf;vJS#k6(cCA8BH}S59-Jc7 zF5XwYH58o$bE@eQDY8d9MK}+{4-FJHDBT)}LtF5?m2jZ1P_wFA!}A|&1r zJKlJNql7!uSM4O4WcV-1o~LGZM;_Vo=q9=oZ6#!j++Sn2(o^G!WFXopC=@~aogy{S zG(-W9*#0!E`Kn>%xS=D-R{E`c*+|iV*%U~M1`madLsy4-?aq)+(Py8$OP14Qo4-{AlTqJTluvRRzM zibv|tX!Zn>O`L%2lkS#=c<#1*a+rSIE|}j*r!|M;L(WLszcK*5QY3m zvdPlIiX!L`R@Ux)!0}z;_~h4IoDD^_a*bdzRi$!6UQ7MNq*b zls%Po-cy4~NadejMQGv1BlOaJ_Y)W)!C&qs%U_)l-OFC6kn!eWStG>Xt0@q8WVJU= zk$T=j-H3XOQHZvPgbi;L(XMjWwB+V7WSt_}WLx+9RR?IMS3yWz=5f{B7Sm0H6pDeX z^ReFaL8TA#CoDgusNanuI%FK5DjqE_x1_-%Qe#A)Y_H7#HlkB+Es6xVZxq?1by*HM z8ZjFylv+Pyyn;7aBM#w2I((J1_OweoK8Z(EPGX`pz$flJqjq=a5s@63!Nwz;E>dUi zY1Oyen1=eIN;UzMVAaBRcyHBv9GbJaW)(%WrruXgCE-@yDa#+R>OIF8xP%RzBE0^q z)jCAU9x(gkeOfn!#HJi_G+=fD9u1g{XOG`}xN4=$6rbC4=L5u(5^-t7xNw`Y?0(SH z8!4!)!&SoRwB1kr5i$0rhuH??m9g)%Izf)cKFE*fk=aiowCpwd?{{MAX0Z|dQBSmC z1cw0Kctj=I&0-@BORAw=UA%RoC!I&C$?CBYY5^|#qV?p+BePeHA{a~Eh!yNmC_)_@ z$s2vl4{q^|B5E*h6cMPUYtMDR%KG^}ebqo9GnfTlh(k>jM~c#6w$-^64oI(+ss}W7 zd4rd#L`GY-msIQAc|=G`Z`6-v^3ZD9y(7{fc(}bLf*32Vzg^54Zg^LE8F^&S()*%F z8Kx&U(rbQ*W+}hc*5QE&`1$U5Moxk4?lDZO;k+vsSG4RP$DLiN}I4~PhI)W`f_(cE-D!GxQAglOPbyPeIxAe`jU8p27hmziG3(M74% zSbxMfsE?}8<2TV2yjVBU(1lD5@w^CM>c%6m=dNj0d2F>RM8bD+O;fl0A)vLa2)t+% zCu2E!kS;JHsqhGk1~0oYo&reZ#H~VR$dr_0N62lc_Bn~8S#4aY5tc6Xy+&3AC%%09 zVki(f87o;RpRAvk-y%bh8>*pc>39+Vv9-m<8hCV%Xi?>Wi`c#nctpgC%!pBhs>dE} za-=#o8m7nT9+Ou(iloXT5XcLf!6WQ!Y6=U*;886a3q0yI?L~_)rH0^6y&B634j~3c z5gehKu5FrPOublRT^uCa!+UxkiauV8SPV`CRUXk!MQ@&MQ2+!#z?BMhySG)7i5Pdk z3c;?%o1p@?eZX~sP2&_8RXN7QR}NVAEgn> z5fayfYVLM5e~I3rJKR@IkqOJ1K#?+#@2h6aXcQ$_H3Mho5zd*Y*K2+V`S8kHY?@i! zd8CT>phd`f>YVuYxAb*jm(M+-B^_g)7WaikZ`t)eYe_c|w@E)8)Qmbs8_N`i4^>0I zQ$!a^qzJo(J>3um{X?ZOrDDEnO#ARJ3q{O`S;pF9j~bM3RVX4-M@@`Dx#Xy4gQ&bI zEa?=Hj*b)&xIow&->LN?pN4L8iWG+k)(AB!$Jm|Gnc+NAPOmeC?*PZl4@J`sm_1Y< zs(X!HHi}U+8btbooe*zO)&+a&*$;rgAY8SATsg@ zP09q1w&bPucp?bqJW>G5On5MxR33R>Jt_Qxwa8Z)@pXOp2IX6N>ik`OH?6e()hA%Y4;IHg$D=9WI_3&u8aiip^| zJ*2yk61eGpVix2rx)xEJPpHqvp!2>>Rt?*QDlR=aQe>8o-Y=4^4v}CVVRb8`qL2A$ zPIl+fj71lBKSr6?yb^^b@)Rq^6{PH5HkFGMeEPlW6DWGE|51JyiptEofJf}Lo=O_= z2zSmS6VkNwL7{5fs%^^nVI_NB1S=MiY$B>IIgFb(Ys74WP7%Pa+NwqGly*wrmh;T(vjM2H-T2t5L)s#X5i5>~E5d)VN#~ zYlNU4brbcEK}b>%So^lu(5(2dO#+Z3>ijWKbaAApeV=jX zsbX}>X+GftK>0S0C_Tn{D0d?=O3G0s63!#wh%$)!DLmplrMJpDukbR867c8^vvGhz zHjA(w^_teV^Ju9e-?1RxUDGP*&~uP9s!s`(tv>7xC_1#YzH_sCxU9tUVki@~S6? zy=FN|y7A}+QHM+)I=Wbjz6PQksGHP~H5R!Q)L|}}f+Kdr)f1j%*Eiw~O_e3}p zF)or)Rij8%C(Mek_rj)70Yxp_i4>VZ?G(}86|51(MzE@kB24Z(kHRF2qSr`6_$(0E zNgkO-M5jnIVl1Yq@RtT!zU?)$d>TawNnbc{#uy1&=j6dsjHI!%t? zktC;28pOpRckK2N@hxH_g(YFt?DMj=Vjy*@SXv&ORfHX*(4_5L2RoY~o>8*NpHYL^ zD54$?|B;$@TQy}M8R%A?h0q~z^hLcddY_=|rJhEM+_mQcO-~G0#A}9$(17;`S zQ98`_D!w$UX4qkJ^bpeHw;1b)wPNdeZO!{$>s4gZB2?Z{|J-&a)+fFZE!4i(sHO=u zTKL1LE8n+;1oHO-WPWw;3A`v$;H(k&6^d^0Bm8E@H#v_e#UX&*c|;od zwCW^Lgsb$H6?IR{DI%)FtO_H6NCGybP2*C3$X$z^RFnrB5)(`#J1YGf_rYH3@gu@t zv}rdEsxlQ%pqfjOM@waXnDat8|B_U;Td!VxmA z^omDV3N=v{DH(-GX6JfpYa@0FBiySc^Lm%_=U5bc1G^dc;5z*j;u5PhG5%!kHkC;C|P_f)P zQe@v=&x4|m$83u)iJ&AD4R-d&^T_%Z^6==b4-zfH42%$mRD{Drw_njBW%HFUBrQTF z)@?F&KVnYy$+d{`4rU><`!!FhrYwSF+fFqeY4^u`zxEpOmbRbSYlEE)p5J!AroI_M z9;)^sBdJOjKofciRs#r5K6h(5p-54~*E>Z~)6V$HmJ$CuC?a)Zu9b2;V0gi!N)i4W zX_HQorbdjr-+W%9D1l@f_KBnvcw`(l9!ZW=yJCur)-P(v+^+kI9Nl$4^GJLu-A>iA z$~5HDvT8bB21l?rjw}4u(jZZe(qXpS8Ew_zk!n}Gn_fI3;9@4_JCDd&1Z#xS6by{^ zEtxJwSx&97cfGS-~PCYsDXuxc(8nI3@OtD5(vDafGwb8)uLagYf`#E7? z@(dc0G3rRD=Q9!*MnY_)NiH!q(5cmfbc$vxuL^QhPF*oV#Ul&~Sq1v}3Xg6SVO^;4 zr(R5qg@+QuGC87^4Fk?Yx0umL!oY1HT+-HB_kv)%j_W~)%WUG;7s_0I8v z%3MmRZ@n7(h}2Bzgn~HYd~UG`Oqq$Ii{q+6y#HjtBbvXQo*W3tUcXbMRilIUhLBeq zPRy0>l6{Z*5r84u)7BUXq+*jOpbHNDgFa!CSS?$oEn-}?cRQQ12X|rE{oI#A&qnt< zMNzV84JN=w(NQH~rN>Vb(*-~X2LV^glK=-N5a?qrgKixu%7)oKk)ZIP?KQren`p&8 zqQmoV@+jtxR3wOJ|7xgAq@MdzFKs;1N1W!=c|>xnI>3=fwy*WbN|C%&bA=0LGpNDV zwvF|3455@KSZp|Y%#1phhJj!|4rQGTUseq}i-w`FYMP)suA0>Y7>_>OKEfPm>(O~c zrO4{$hx8ip55tHy(zo-7N|3H;87TqcVUW~yS*Z+RCSA!L6&}$wuF=eW)u@-KfuOKz zu2LIC33!wavptcPhercuCs;Mx*Lir94zs;vB@d4V%>H;e@(5!Z9(nnE9*PD#JHe`@ z!)z~B&$DXjFxzTi#iA6^nl_@T(36ECi+beYQ98_aFQf4Y50cJI4{ny+5k*9%kJ}*T zZq<^B=~k@@cyK?glaZLJQZ?oX5H2QD#`KITBSdScWWL4|Px|b)G^^&t4|ym`huIc^ zFKe43TH`%Vc~&i*oo#&!wrYwWsn5e)-5QDTssIgVBv>4Ff1hEes2^3zYD+11qk~1K z9g$8qCzjG70`QFosy?LQuV#dUPdoNOe!P8TdECe&rn`6vlz7C&iX^6j~phCpI$g@AxZ zhF6JrWVTr2QG(r{&d&B}bZL0x8IL>^*)GaMQM%ZO7pyfNNw3j&Lh{4db{}MG$=&qlS^pHj|6qELx^p<3!LRR-I@(l3r71Zex6* zh<*{X>)uyw=sUv7_Ut+oVgGOXoHb5k>}m8)5%ou*TMRj2 zW||R5oyD;G?^UeyL9wBoA{AgWI>%OxejR9NQU*mde7~J@?ATGhr0`pP)f9Lb36gBu zvfUSXtIw_g5*hjSUTMAfqHif`7ofah9>bC<$@QD3UpMhk6p!&WsRosy`~CM%T}>!3{0S6N>7ffW)jjU z`gnx&0+Bov4VeA$Jn}Y-G(57I=^`k{?zjFIqey!VJ2q$$^{(423ijHF*&t}dY^)7V z0xWma++*y?S`7^jD&|l7ki{93J}2Bhyil7G>(w@&|6YgDUa(|C96@X5`kNr*jG)%&^Zg@7D#)Yd!^ zMd>ixBE7~V@Cd)z54C3W80B)*SU0hH-)ns?d#ODp6-|43y}EeoOv`9;M862#83DZ1 zJ;J0IT^#VpGah>d8X9|bWGQ*|ai_T1XfLfnyq{!C8DUxLO#z#puU(D8)6}eM{r*T^~{+f`H zZl=P1X0p>kFRPZN;6}XLoo93e=0Or*$GRqsR5$J>x&A0(2Y6TEG) z8DWR+rw>*H^FxaBwra#*ZmULsjma?LH9zznDK61_j%i>~Sw#I5$yR@D4Jkw(nat|4 z6g*1T2MM4y9_HbZ?dv=gnVjXJXu#}`-~AR1FVd7_uf1V5&F5hjD`%vT+pH;Ys3w4a z$D=a)r^ndH!xPkRl7Lksh(0}{MGFnx!nP{HBSOtZI|Mwk-mOGDN@r(#H*wo*3>Ga@ zJq@N9R?4hPj~;6-g=toCnnc1)({fabjq2k=B8>#Fb~n*Bojm5vda`RsH4UqV-CNeH z{>mWPeZqR<(TDH;eu8lxin3ug4%1zZ7*9>Nn435pfq>+;=4r0PPru_4kyw*-K1NtM zw9|TBIq`y%vG^0SA?c$cRcD(9l3*3+{#O=u+tNOj1TbLt{tnfo%h|(;7-f567^%AKW7n|#YV79<6_IVmwCsq56&FW z%dq<`8eXo_hfE_R@a(NNoHF&KB*wJgtl6wBY_Gd;c-Sq!rWtg89szS}m;=v|LPimd z20GZLJgXR-#IwhW@fMi0YZAmEdmWF6N`XgSjFpEXTh%-irNeBiT@;Iw$Wb~w`>hWW zz#x}x1%wY~Ix*kdV>;MAp1UpxiN9<3BqlREg*2YqMBw=_2K$7_}9)OU{u^B6U zDRnFBRez<}{SMBeDF;RA?Cf-XkW5ZZCr9Zp+v<}Fr*cSkwshyIu!Fq_(d z@vK970qV!~nhZ9i#Z`@>2mSb1*3J}4t{9opzJ*<_PXR;IyD zK8+Exo1>O3>j{rILbC?2bg%l;kL=Rx6niaQA7pE?X&lSJqjZ>Uoe70YIe3%~v%O>` z&0b5_2Z^2E_E{bt8G`1aD4m@>o(K8ySqQJa%(H6gFnjESOt5O{FxzV{)5wwal8T@l z7MoR5CZZ@EX4@$ZiFjl=fjn}QE;eHGND{4Dx_EZFKFD5snMSfLJC{d}()B@7Pg%HA zf2Hss)Ad1m|4Sk{N{87#7hg=uAxG&j+a_Bik|PTfr&+bJ5Ax%^qp=S%0Y&LBdpr*^ z0guwz*=IV;KGVfUtOGa?LXLfq2_!omW~b|e!A(9OP;fIP>r*T^}T4e+zf&uM~2Wt`Cxt`ssL-4zttsL9X5@rNzr3 z+1c#uHC-Phg}mAJTDm^Sb?k%u@Q4;|is@D@9cFtkX&O9A*9W<#I}dWTbHIvxr_dtl z`XE z?1TJx%ud$_xsH9133!wav(xoKu0D|_ji&VjAo5U@E;eH4TomL^p=s0gLH2`<(#TP| zK1hb76bY)oQpk}XvzTYq(#5mW^+B%Vd5|Bk`_uJ7t~S%5Y_=SGZLqT+oVCY14UbjhclGumn5AlC{tO!we;AG~ko_wyh%OOVs98tdi*=B}=fkMV4=8^>*tZ9bg_|ieUQv^Ya*Oy)lBm9Q1ph`oHO;@ z+_BUY&#j+Rz_}BGXvgeXQ$O45aun8e>A1kkch0ruuv$*5u!&4m@^H#$Ta_0F#4)X} z2C%~JPuB;@LB!eQC|w^U=Z&S~Q93)@4-ZeX`_uJ7u6|-%9v-E`Y@hj_hDV0@1p`vp z+3ETqIk3KPr~b;pqjZ>kro-%XeUNLqK1e?aHPP-*huJPFI?2icB@OSNi4Y~;hU5S%dC_@jR^Xpt>lA0!jS)A1-9 zW^dzpkO?F^TRfXHEz`+Sws`jT%4TP8>G~kIbbXLa_|GQU>G~i^Yoy~*w%Ev)t`D-G z7^lTcVITQ{eR(KKhuP`+AUCfoNwaF{`XD(EP0VRODfZf&4zttsL2l{#AUSH(gouB0 z$Wb~wJ6#{-maY$ygTS)MQMx|JE!}yL+ma5m)Ad1a>G~kIbbXLpx<1G)T_5D;h1deh z6q+_&ALN#<4{}S_2g%Xw*)*+}tLBmHbn)zTeUMwa^B}i$eUO{?U8Irhbmu{C>G~kI zbbXLpx<1G)-Fc8(x<1Iwd*$-%{&caCbbXLpy7M5nbbXLpx;{wGmd|F@raKREOVG~kIBVFA{x<1G)T_5C@ zt`BlccOK-Ht`Blc*9Wx10V^+9gw&V$_2^+7VoC!2Sat`BlccOE2zJJPLMIy*aE zALN#<50W`8+2knQd5~MWKFIA#huP`QgWS^fL2l{JgWRrcn7ya#gWS{gLGJ1LAoq0V zLGJ1LAoo``%-+-WLGJ0!gWS{gK{6dRnZ>rJ>x10W^+E3G`XKjoeUSTx100 zoCo>kgMR+}%dda_-CzFrZ~yu~|MTykzyIaeKmG=EXbkGUu3uiSd425@|Gw6FDgW{o zDTV3vWm@(bV|6*U*O%AC$NQJZ>o=g~?Uw)R*MIxvuaC!<|MG|b^UGiV@cgg8{OM2s z`qw|aUH0W)Ueo)V|Nh^3L;)~GIKO5VX7XvZygzJ|K83c_$J-yOR{n7@$NJez4NqR3 zt5>nC)2j@|)t~4t6VF;1jH}n0i@Oj&UCbh%pV!XepZjKWap!AVF4K>%CnLG%s}@;D zin7IEnAl#wUiqD&uHf;=rW+oQ!JdCy+q^vc0SD)FAtoNFS)LmFUF7Ik zk*rpO$M|&g^L8yJM+-wH7yA@Bn!u-8WF6%wTfgPwk*%ii@yHf8M-uLPO?b3DQ7G;0 zf=9D=L4ij;m)r0Nap`z;zK+X!@22N6zpmG^x*Sn3xR^{LM+-+U)CTk*M}}8M4 zKdyb@LwZSyyDd;K`+Q;hHC@SB8rLz+^WJ%Mtdms? zYp)#(k|u^m9@#e6`^_4epA6U6Ykp3!09(^^4XZXt_FUkgUW{a4%-OcyJMP2w=g1DH zh;vo2lFFuUQAioMI$_L1JOhb-rOdi4Zygv~q!y+#S+ zY*~8oh>cp?nIc8$Fxz*LzGYc8AmX|EG0R2w&+gBn`)@o#_dAAHIf6qLLxo4ve!xaw zHCj9_>t8Bzw9mEpBk*XPYob+Ko}9~5*P+PK`tq4I$dRAzVykwuYA>ekS#EHC;+nrW z@4+eJzNhtgLD7MORF4OY6gBK91n}P(pk($fLo|uB(P27*_4IxGC^m-G5P~XdRP6 zdrZj7cmI5GB!|@uzMdSwbiS$}M~Vi_7DfAW@=&qx2%Z>5K+#RI-@Kz^o_6EH{9N&s z_!E;O&Iq9`xA6cuVm8-WldX{=LmKfUha3%4VYai+P$H#=(W>#Btqeu)hLp? zq`Ow{=%gsHy+n>)9NIW{gq%*cX5)b?0)GJ(>q{G}uSeC8pJ@Wgl_yoSkHgWFMSq7VIPJp$0&Oq5B11j*{*Ap;7el zyMLT((&Wg8ixi8EE!$WIk8Y8O3AxecGam8z?7NA*#+-tAbIeAiyrOq>qSY#}L^(=_ z*{(zLteUMy9*S&J<)J7YW;+_E;gR|1A}9xDr<-f?FdyA`)U=2xf}%yvm+RxNStB?5 zh=_q#1y0WswG9ZGrsZr@Vz+LM5JaF3ebgdmr3Z@Ei_${ij%+Moc7+gfjo`=7EuG|+d#wg-j-6@(T zsowf=jj{Owv79uxa(LjN%z-zS>E2*H?{2A}nbP#XG{nD-a!dG+;K8y`CJIYl0))e@-Tik|U2i z=q~ctP}@e zqXl39_$Mj7llZaA5oc< zKL-~WQOSsrza5*B0(u!KGJ(kJxy;JmJYxcdi9IUYA^xzS8 z0DSUQTT!&8W3>A@srP-a*|VG?v={*eBUHPeaIh&A5OUc4e9J%)3$ef_-As~=l%VCh z9L?tr2-Q!K>>c8(SrK^T0;9|7?%$MQF@e{r@kMNHS+#*jcb}F#C*PrcODs10e!?Hl zBX$?M*C<-)(%Y+uMvB_1ma7Uy2hSucU;pfJE>wSTpY{?>IcSmB5j8E@G!$1uoQViK z>#{qKR5wC`%_({jMXlo}B1Hpce|#ju(4q6_0wJf)BSnw*sMm&7LwQCynhp$w#!)sQ zs`gx+N9=Y*CXGj^xbv!`ULuc7W_4LvHOw>RbnBlzFu0y5Dql5#AnrA!!qK2;+VhZw zQU6$bO{%r;enx{HwvB~H(}jl8#gQTtVZC1^8$5bh60B$uHi*&9CcIH3JQCCN*G1E^ z*JjH?keNI7oxgU;#<1Qk^21)kdTZZ3Qe@btI~Iz_6GVh0HcNWfu3BnkizB35593+o z5hsJ2eK$P`+Y;mtm`#4tb~ii%!CU!Mq{#MlqbPx78x(dPQBr^*qu2c4+^D+Cu3C<} z4TPlpxeQ!=rUQu{rfJ^2lUX?>9Nxo`)BR3bQE%F=+!K z->i`sJtoCClMd6(DF2dmJOj%vN6O+@mj;S_U+aBQgky}Rwe9ja4!j|Z zWqr(#Dkx2EbQjDC_i+o4WNz60hDQ`U5yN(hu-*vsmpdu=y}+TWcq2u&Ji4s$=y-aW zRoQETlzJC=N50#2m-omh=AG#ryrboK9edA_)u>ytCl*(v+w>H+rhGL@QAO+s_Np%BYU*oZ#*J% z>`ajy5pOq&(ET@x-aJThF)bY=-Or)6JH~*o+5{ZfJTB?}7qOBzIWp{P6n*^e_o#>Q z=p^M$uGqHVu?a6N{_?N=!_1%x6#lmd6L`f7(nc5N`<;Wgg zz7)UsT1ccRpU1Ht(m%#BRWup}y32*GwAV$lIfQ66|A*aAl80D}$q^J$!R31mir6$o zY$8R5#*Lx`a%A7$c{GEGhXq_72Z*?%D)ccw3+9FKMBfX0@xE%51zt7>gjJich`a75 zg*$E5b;hdgAkrHirJHMlMOMCh{iXjVenJI;;}J`uTNmFDdPWDqczSoc~EW$ z<{9j=`xoL{ev-#R@t#poC}R8D>q60dQg+p>awwWHtY01(oyh@s+*E-S9NzlfqhuS> zIFELC)S^1PM-)u4WV>n^yzG-owHrlX^2_3SPy|QLo;ilsD7}V&;t}Xn?Vd={fZ30O zhzfecOoE+wJ2r)3#EgSx6zDF%;Z4)>ybG4rC5IxWZ&88NS8XDW&^{GH?pPz`Wu$1p z?2nghtAi=uN}N!rn3%drHh~4@c#KEb7Oq+Ky-vJn<5`iTWyZni2q_=-bUPabh1K14 zKfx(N7kYHyk;UircHL`Kx)K>Rim;T)9fei9M{9_DxTH79CTY2%SMXq(T$=6t2SUZ+nwD*gtah@y@qb*|0d{!+it4{yxj4KqEgp_@{WjD&F*Dm zAFUXU_14&sgqqpBdKr0S&(iz4mMq~FZOBQvgl$dRG3@rY#4@$@7ZJUX7|V!P)tpLZ=nknz6zfzZP| z7vzXwEPQevQA38ur$=dtiAsDWmz{2|2`R@)arrIDrkYVPEK@G(9zna>+EPyKdrNCi z-R@noNrO=9TknY+De%za*+?Nt0M{aFlxV|3yBraGsefI5L(zxJ5k~QyB9#4v1!SQ_ zIw;8iZEmxWkGR>{IGB!46|<2WD_j<4tFo@|erl;t3r%USVVYFWF!E@?><6`ac-dYA zA^VLexUKC>6N2GSS+!b#;E_>w|Begnt455C`eT=DuwyY#3yLuRTJSznG+=guRU0vz zY!v(14AV!67xkJ^vaY^L`d<5iPadsW`akd*okyzUUp#k2XsmneS~V=p(LTZ?9Oa1J zf-h=sa|c=7_L7|EZPj)n>NkoGN)jyAteS`!L2`=?uYbo_s856l=Lv~F|=LTg5P7ws+7wBcAXvAz% z@I;K<^2fxMXKENR;{+H5W!3ne_PXpfOj=4Y>N92ePtZp>X0>Se+wCp${>MkVg{B_m+BvEW#i22j%L;$<*HB6Nd(R$H3UxhAG zWc%7FB7hWXA}C*fA{ZwB#F6hj;_&kukBBRJF9fSb1fEENQ$!ZT`@AIC^hMRx2o$C3 zgPhEw6N}oakud9aw(t^#Z_+jm{cBX~xSp$+&2BR7EgmfhOW6G=O>0CGj~L25=CZrf zVHB+wKI7^R0dYIl&?-S5_*+gvk)whRrW{eqY;baZ<@*sCCAv))Vz)-H7(Eg#8xjPs zNtC#117;J|-;pCT^r!_?HIl{59~0W#bhQ^JekJoEv8;GDH*%SmG0ke@PqJAbQ$kAP|apuqskCejq_F(ezgw%P%c0VBn z%n#Qh3JSDCW+RVm7v}Enzje|aq-}o)qx?|Jrb(#g#mW=vZ)K9h(|Yr7A7`cwwnU7Q6ohZncO6s;0uAr zwtt1$lw<`v`&2Dr_eB6~;6YCctL9-Dy)WI5c>q^Dexw*6-@^zLzC?;Bj=3Wwc;pc| zcIkQH7znro`~{B2r|}()&=9K#oStCU&X3gBgu{OYy{Zq{;^)kH~4=lF3 zWYZaH6qbdc63p#ZB%8blh3kfpw2Fa>4FQqtUDnc@9NDAw$Q-Md4zs-?BoB`U%zn(M z#!#P4e2tnN%TCiHUBt$18ch_4a)j+c+`LHwyB~{^=1Y?!EN~JLL5@gf*RV^FY^#GQ zlAA(~ysW3K8m;5xW_p7N(NwbQ_Pt2QmC%Uu2$%I1V_PX&#Rx6m??Kn$3D)jzXHytW z`D9xa)s27@V|{ijlBjnmn9ZbwPidy7gWEJ}|ak{iA3eh6+En7C@`Fxz@13QMHdC>E!Z$%BDtSydkz%Mis|M2kAw8)g%tW{I2T z0wGDDVfwpdW51J7uk4q7giA4I*IiFLMMPAHX}B9l@>;dWhFYy;)a8hH`Hdo^M3MaZ zOk%$B6nb8SC?o|FrX?trmEIK_qNcUTic^H(Txk3DH7UwccSiTurfz*`?Xd~n7ASg6 z>2j-Lm1JXlY+bT(w--qw7nhEzdZ$QhNch#H4eLVi<2+)>!cDSq zQ( zV&kY{Y?##nk9f5kwiP_0|8A6Qx1bwEA8$i?4#s)(A{IKEa8lkwwGVR(8_O7h;Br&; z8UevOj}&ZZSA*GTR>B{SM>4AoNrXqLE-ykCSIu^jQA9L0X4hw`4^`&SC?XMjmm_*m zB1Jed;6Z~9vIQh!!9b@-!Dm}jC}N`laJqG*$aYbqD8Z^3f;NgC@~D_`W2^(hg#{+) zbe!CHgn8pyr643VxTl4l!G4&4pgWI1OH{KSRW2qu*9zVvkJ{(uBCS8h2t6wX8jqRi zHpwibTPo&;kQ9X9SB(g}X)bm@xhVj{DZ=xZLdK84%G*qq-li&&3Pn`svEPjZ?(rm! zW-s65=u{<+2@cE!jDX_u{jiV73?VwfhD6MQPb+`2YS73dTMws*E*HL=0Vi=0WsdEt zt3tGE5lFw`k$U{dEmVq17J_tp(EW7WSjnzr10Q{?t-(2~e_ehT9x<|nh^8@RW^*ZJ z->xD=bze22j*&-%87D?D)T=>S5E|9(t42wt*GkjT0IJZIq>BTOtTLzELloiDVJ4XP zfk!+M*e##4u0ur>qI%o?6m?)BHTvmaB(1 zgb>fheL$+bLh~a09`Ok5bbF~#M7I5p ziU!R7c)e!%x4t^2F#|!k#%TSgOF@JyjJ58#YQx*`tDcX z=4-5B$51b{)L*Px0v^3#wmL%GQAY7nA4P_@(M{a+CfUf*P1DljOv=1*0ee_`soUA| z^S!KDazrml-Nr$VEK6al_VGM2d^L)&kC3B2vyMs`>V(|s#@W5`h`5EvB^&5gCqwjv=?bMRARXZzu2FdRAk)nu@6&7E+S~Ccrmz$U5nts3zF)mEHT=tEpc2m+t<3RX%Tv#+|`v9p{J`ogRDtW8l9pc z#zqVsr?q`ctOE28io+0+B(2cFD54Y*MPA@1Qe>W(Q^fYciZBus8v$GGs+JV(6pd9H zw1ZGEQ=bX;6F{Ka#wo&0VZ?(`q$3ZGaXzF+G0RnukpPe0F`GPRn{NY|S~W_VO|0-9 zZg}*j`zf3zp6fhP!avlE;-pjIU_8Q5pcc8XKdhR?42?(FkWkcfN7NJ1?NeU7-x;;~QItJKv4-)5te#VA3`rc}38S%)?SCN!r)qFh~MGqVnwv!hC;{ej7 zZ?-X&$@eUT&fd81esYjzPvB({0VHVMC7Y?FcZMq$wlc4LM}CE(TSN;-gjR@VDWG5QszV%- zJPnDOruCqRArojiJvrz#H_bXl#E*Q)8{QE-LM7^Be!fCch+ELGM0CO9kno5aTdEN| zkI2Va^*Iy~0f#6bM zf27EsrHl04kZg3I8`gy)vS#|2pRZ7Kv$L@Yu{hc@i5?Qb3XxI5K6LAJEkfaU%j89h z2Fx~!>}^p*sP7vT-6fk~jQ0eIq7vtG9?=HC6sG#+5IRyQ?-dB?&UbG?w@P&mEn<^6 z3Qh3y<29|v^F&e(ikh4mk0ja5@w9T>f{@f;+f{FS4UaJ55h*-E)@>gk+4MqygD%-b z;M|K4LMjkBTK<+*2^49fh;J@w5f$u}&%e6+?|Th3K}BV~8Z-xQx03G%5ZGKq6AwcY zUXn>dx9Q@r`#mVD_r(cC28m!BQwl|-A@ngnZ#*I!b>k7y8mfWo#q@X)kD(9)9yN+I zY|b?;4GrWW-Y6O{JAq^y_UUWEm;@9VI5YSh;B7#nhgi)E3BudLcFdQANjX~$+M zs2Y~utz#~0D|;yJHM7OSs_{^V@~ZoN>rodi0(^hOTI3QL zRi4wV5oQ%Ip@5|^JW{u9Yv?Z*tDne{ZYr;e$cxwbwzXj9ElRA%j8%F05wR6zn6fwcj&v^ll3Lr)v-E2tBSlUf? zHU9{wy43pdTm?7?{PZ?$KEecjqsYE}rwAL8?159H8g|cRe}zYP%qF0Y?OOj>Ou@=6 z@ob(8NUL+)6qM{E@`Lr_$fH7HdwhnyM(uK=M*rlX$ONWQgk)o9_jzpEYnsj3=q9K* z?6rH>Az4PCqV0a7#~?wN5JwP*ecA*-A|PUGlra^H^~nE znuZfVgAEoX-%qR<>8^W?QFs&sVO;xOoxEHFFX)G;Tjf^g%S%M zv43nwep|0;b7=@%3p|#&$EY?%*x5j8X1tW7a2`!uI`-6H#kKWlJc1%>3cSz)igaJE z8v6JTeJstM>7dZS_fo zQz;PAs(}(wG+=guRU0rn0Y$cp@<{ezXD8s%fY~2Uk@*dI_L^&~G;-w4e0eBJXJ=cM zB9R=W!)$NC%p*tXFx%^#^YADgW_uL2@d(SGS~`NjW%J>h;6e6NRo)|`>HrS$BQ;~S zqh~1f#)ITYhTbotF(HQ~6UhgWM8U_@lY&+2r3Q_nkJoD+8OlRZI?Q&DJ`a!5VYW9t z-y%ZqyMM@wP$x@oR^vOhegydl?70(5hd1Lv^yL)mjNNYI8^Va;E~s-Hj1ho^@N%t>?j8Fp}xx_dc~MHqMMiil7{FWOM%#Q8d`u!Xxz=nn5Hy;tVj8ws*bOdq<1Oqn={Zm3T)~Y%-wQ>?4dL zW_@%#VywkmZx+`S?$lpeLHsrPAiZUaT0Lqa{0{gjon*S+!fW56LSkYa8F0cg5jo*fPFq zR1wicTRBK?7V|5qnbOP1qsHMoMf7~sKPwb5XVPANMX%km>x^$wV>JwOUPlHnC zLZOS>N3@REF@%w#beL`5C-R77p_Mh%RqIpqzQUs+5~J3w?bi^C2};Z}Ki^#_uYl?iA6< zMe(#=MvClNdcRUcYf;S8mO1RUwr>;--5JbVA{p%d8so+(rS?=Yg}<6Au16K{Vwip# zsuwA;U8IYgN0g)JH9y7j=K$yW>T4e4U9vIQe1eN67wq)Qy9bGHc{0YK-b)=;)ZNuW zqDYZFOP4i@sH^tk4N)Z4|80tH-Sm_R(QehQraE8!ETN;09&I0HARAIP=G&?bnEmk) zEw2S{JW4>32~1x#Dp^8jCYqM1Z-%39lC2q=(aWYr-K)9jd?PGDJ-lN!l`K9ugjFLd z!Oql^qa4|@^6<#^bsmb$@<~IHMVCd8cK^pqw#6|LQS=qe#*THPQ3y#Dsa^GzsfWMc>sf1K#`;3}4T^}R^m+JQ^ zzjNSGI?Q(95tFLL#(6=}%a$eJ*7*BgtIh0{(TD~vvD>W_iDF3C-gV@Nx;u;rZ1%p_ zxVYMeVXu9y50Xk+hpAFmi&s@2$=N+)73;hdiFmELJT4h7IZ@ zJh;AWnn;nMapw`U#;6%=B+Q)Lr7@I7(OboM9nV-lhDVfv6923(K`MMD<^|NfMo}Z9 z?ZW^9R)YEdZxpq^F83&_rt_wmThvIvw*d>h>y|m90z}{a3=+HLMNXKARagI*7zT5^ z82n(%M1qBLbs9FP50d_y@g%Pv7uHP*MO2p3`Djqi>_VNlXYx-a@r@!ziG|u@%Baas zGcnsJB5gy{k_!&L(8Bn$`YAIy)LSz4ih7qoxvEg4iQbnn9)wigtmQKBjz&3R%3jnW zM6=No^_kF09tr8LtA>li{B({sHkMK4iv?W1Y?LDt7~P~$M8iiofr&m*o@hQHr@t0e z-&c(;nMe`C#b|YG_hh{pqDf)Dk-(UW6XCA(!XwG~IB$f)*7|w*4MiWX*F5APk_wMB zz=JK&2-U1HWX0%aSe#hWc|?b9{x>o8RYnjw*;=7-L2V_kRNocquVNnBEan(#_ z8$}<_qjY_c95~sQCl8MX%ucXsCc=4mWZ;~KBHN33D0;(ee5x=Z4m6>f!mTJ~VBYbF z5ZWD&0BJKEI3Jz(HAfs7W^?=zSyPi-wYHNXC9f2=k2&Rqa+$U+^mn6Jv6y_-=ri=OifCH=Npb{wa$mJJ zDqe5$lYvJJ1FFO%qR1pa50A28c5|27%4r2Pb&fo!v5v!^)y-x$iyFKPe{>dTPMsXgB%wEkyk$J0mC^DH% zLs7auNc!u=oc5DqulXTjA}R+(=`efjgM6@#oCM*;t)w~eX)W8!9QHc0QXDOqeLJJB zV787)*T)K~amWH=wLJ8|+}n+|^ZF?l)9A_^QoRh;h{qW8evVa3huKz{BNip$Q98`_ z;}+8JC|w^U(_M=M)nEE=1}CulZBX!oL>6Ilf61&s&&+7Y(x?-B5$%2s?X+CHqPP@T zOw!5$nvWPZJl2W2Y5Xt9lbkPn>;%4{D~z#CH|RA<%bR`M*`kVJ6~wvQUNcenoC34G&`2cZpeUW4ovsg(y;*l^ z9yxMrrODBQ;plj=K7N#1Gx|`RlN=u8*{gz(WQq)*B#2LrTchTveoM}_+!;33yL`w$ zk`ypaihV@zrf&9NA6X_m5s%ElZ#??&cs6O3%Hc#jGQF3FN9kfC*58(B)zV?MqeC7! zN{88Ah~0QZ%pA-P5q6T-l!4lg#3*%)7S3*%mv_u25n}OpCMHwW#+i3!Lu$+*r&tx4 z6~I$H0jBF^z-;U7C|9MhM(i9Lqv*kbt#tHzE}NtTxdf|Bdr)_Fv$H8?4!NUZ`Rll| zayQP+qC#S&jLUhX#!O!oS^gY3T$D!SQ98`_f;D}u9IIw>mWQHrv5|CrkfdPiz9_$Q z$Wc1XwvL=UJn~7jY4)0RlO^I&I?NvXAV1z0G0P#*s-?qh&oAWJYw0lC z6cxj}?6f2nn@{V_!=rSV?Vea39;LIhtuC*~b_yHPPkPL=YUwcB(^hGCl&%kwvExOi z>#r1&ZQb^Tq#P8b!)&YZNW`Obm~FL-iFlMQo^737iFlMQHsTfhVp0k`vhKG$tL6#W zJUmK=+1~J&hezo!+j}na@F*Q-kA09IA7k^Lf;6j^t`Cw^f5n{klR}GF*HWP=2Sw>H z+cU6YQVt%a!)(htCz7LdnC&x`^T<&)JDXt~MS|+D410|s>FFrSR_oVBqBK6`ST(CG z5>YuQ%7)qW8Kjf!Y?$50o9B_EbeNs450WExvq^TkK1fFDr{hsN%ud$_$=t1UtCkM4 z>!B=-PbqYNx<1HuC`%?DjeU?G9?@d{ezv{lrQsqhg=DAegIwoyc6Pcx$koocD)OB} zjG~j7o9R&2E{9~N!)za! zBPONbk$2qXp$NYCPYxcX!)zavooCh3VYW}C$-|>`v5|CrkZZa=$aPH@&ra6|$r%Zb z*h%zSx<1HtOBc^h*9W<#>x1M#f^?FdE}rcthosT8V;|&$Lr$4&?IRHx3(VOrPWQEx zVIHNlL(?XhZ+SbV>f$UC4q2*_aB>zj=dkzlAa@Q#iRX*xc$8{Z_sJD&x<1I&Pee(x zYGWVd12!@_%S+oi#EDZv+=n{%GDgc+jnhDUu9i-HVwNBa+g6RUTsT@|-TdrTP8*qf zwu+%!+p*O^Xk4{)n4PW<6uBaZ}(?x<1JDNQc?!`XD*PE*oa2>x1kk^rhKrZY<`ZC|ztMT_5CX z=lqo&mjbiX^+B$F&R-tMP8S>Ta~1ROD4m_1t`Ble*9W<#>w{d=^+9q_dqL~^D+Ok! z>w{zhZaN;N!|ZhDL9XfgAlLCc$PceQ-qQ6!Zt40UnJAuY_iq*rFLY(V?Cq7UZiM5< z(ydxH%-&wvVk6rto1NVQ*Ak}`do5ib^t`BmvbHIu;rO+bj`XD#Y38#_lbbXLpx;{uU@YxVDT_5C@t`BnaQw;O$ zH7gKFL(zC1G~kIbbXLpx<1G)T^}Sz+-1Y;bbXLpx<1G)-Fc9`hBpmnr|W~< z(wzsnjpspryk1M!2f3v?4{}S_2f3~3Vk7DLAh&dVkXyPw$SqwT%0VAZnK`fcg@Ah&dV zkXyPw$SqwT(FTC^Gk1vncZ$Zp>&;Rx7zy0#p$K%U?`NRMD<*$Eu{?}jr^rwIQ z>mSCezI^$Y*Yy78zyEh0K>!@%8Dq;@O{|T-^?2M;QGE(+(V2dk^aR7mpNz7#l8pIc zwsr5z+V(OQ*XQC+ueH2WZ}EE0%)vdZ!i2fF`!!wXVsmk)lR>!F2lsle3oRct*%~Pt z=9)a1;Prg%Ui`RB`;!AaO{eYaKoR1ncZ?$9r~7KTK_-09lVF zU8KmEp?ek{{S-yhbj_31yE1hc>zvX~DB>~KbD7yhvkwxVpl7a4ACaPAuE|gGXkr}c zX6MFE%&wnTj*>GTF^>M)t>=^_eo^*oub ze5|_@c)hMx*7TqL{qN}?`38Oa|2_x)AA7<7WBtVcA6dtL^xA;`zpsGD@1MheX5C!R z-A0=;CVk|Ki5A6)hski2t0Db)tiu zqGNlaR15*pNH_dvn&pimj^bE6uRG(QT<2?Z+m=&67!TgMPr!c+bHGpJM~X)L|2c{# zP69g3+Mb`7w&!(-M-6R(Udyq9w!~cbT5c67vTrX+i%0TvJbH1alP42 z+jMoUjec6s>V8FvOhW!S6v8my|4G$kxPyP>x|NmpUelzSB z7-8N0z44zF=N|mWJKR3){~rSKfAHdh{|JCY-+z7%|L6I@qW6JL$NHSk#iK1VkZpLc z-9N9Kq7?0a0tK_x(1C3jX2e_r6F zVKNr{%_C7bB~mo&*z<=}`mZn%4DY9qjebDy9dnVAk zBBlKZ|9_50(?v|os%UoXe+GJOtD`NhfoG8AGA-v`+an{7M*ROtiWUUJ5dOrDz>6yp zsj4FSe>)ZM9sDO1@Ur;-N;FvbkL&h{ z|NkJQ|InX3x&SmV5Egtb{%_W^E}P=MZMJ&(^BmYV;y>qTUf{Mt-ZXL*kKKD5QY@iZWQ29v9=RY_$+1@@T;S$3%XFvjgqzNghY< z&p!4N66-mVeF-}9coP4|UTsQ|_&?`2az#bkjbsbajHAc4iG0N2MqqFDT)49eSnGq=1=|ai}V}*hwFa}xd~bR zztjJ-&ffKATEwg5O!QUxL05Xdzv}SBi;GSl^ZCS#a|rHYdfxOX|XK@ z-)20WM&QLu0%3dcS0hEA`rm^NH%lY(=u`iHpGTki|2IVE-~QIW{*OQW^$*kU{$<)e zO#g3W(7XSC9Mb>H7XH-#zy0ce`SR!jAl+1dzNY^zSXQq1mj7Ss|4u3Z+RavqudbJO zBB1r;T)S?g63kyq+fFN|TiRJ5)af0|Ne<9d-7+tf;wi9*<|F=#=6luQ1`)SSkBS0m z+hsbRWdF^1B0Rn0rCZFK1fEl%yP)g+b)g8AzVz(X!~;(YP@m6ZrjDQ#78HthobPr3 zO{8el|1%~CX-8AS=Y-*~SVi9hYd|b=9#Ot=qloO^wOH_=#8aomM$KMNuAWIrRvtaz zF3FTiex%4AZ9L)*vK+)N{ZN!ijMn0(k7b~U8kieJ3pFp^B>+Y1Nfk^}4Xo*FIr)FR zGZf9#biT((2LJy7*-zr`woD{xIkmNi!6E)n z(1!@H%Ml#9-eV*t!XjLZq4Wo1%MU$(B8r!MUgUQvB3n&hrgA}lO5Etx!ZgQ|lE^(K zIw(@z-zhQ?zEk84{)HlP!Sxy6=Mjdao5eddTiB77*~TCxVm`f8R#YT=Ip%YH&uk3( zzwziFqiBOEI~H_f3Nf*TYFo?xvum$?rS8=zB8MwU(wB{rZ31)S5e3PODdG|N2@~{h zui6TBsgShU+6&7+9TX&25-0}S4l0X08MF|%rh06k$g0^20Y#2Ztbgib8$~dsT5IoM=oP6&OlwY{UTO4@+dlcMY87^-0*bygM=98 z4S08b3r9Ld>r_&BzSmR{jR#V{4uS(kYz$u}DmEsYub`UkYd>o&Hmus%&-0kc8&c(F z%XA!1O3JLl;6b*=@ke)Aq2Ca*?0)L|DAK4Dv1%7JdYe}fQeQ~Uq48Tw@uHBtJSkFS zc%_?^Rr|{BKOLUFEk^=r{%0j9RHMKzijZy9CTcjQ%UO0zNKsXSk)k)uo@cmXstLvW zL>qcPTVsi@nsiR&(Q#3uVe~^_acdjP#1yog)og>=xWFX&#EVGLh}qH$)My%TqSsz? zh-(j8WYlX&`aWCdyHqRtbo1OV2|L>2oj`nA%EZdcNRd6dt=i4E`*wJeyZpe_-@Z6f zWcxY~MFxc*Ows=f`}Xr0-{wFu|K~jZ-!!TJYoUDL%j2{E>)UJh&-k?Ze? z{lEE1wRf`)P|cWeq+Hv*7a|R&g@lrvv*xdh=9U3tlRYri4oWjhZ6io8PXfJYiCmNv zC4G2{x^+O@N7E7IiTY6fANtFH7<1;>yC;F0;1uXCbT0X8J(FtsYqu%Pn5a8S$=oX_ zTK3gv?8v%V*6-KXhws+SqJk=Z$`=wv)Yec4RbNuu&I=Ft zLJ{RisBXKM?#kEp{rXQO#b0z4)IWP*E0D)_t8BCY@f+?GU95zueRAzD74LUL9ovG+ zEu)Cu5Hj3vt2Wva)cHQoxfc#&SW*jSaedZS9g#&Zl8?N!U%tZq6^z>Wucl8%BH}IKh|dQZBM)i zLIBMmWD$uuv_VNxvTb?(85EH?Sjn@Q>!8dAt%GKhB7yYG5q)tpo;1m{jGn|}uqCj} z|8X8I#4bqvEzSR9L7DNx{;nk8|6%Z*W)NaSQ+ELZ=+nrfH~;S^DB`=|bYPrU5)d3* zWXipbBB;ejZZE+jpz2kRAPf|}`+s5M)OtU1Cd8>{vW#ZL_HR!u`D1Yfk6|i?;#|i9y*uX)lwVhzF2ro z0HmH>+uf}H3{({4ixe3Y`l=zzbMLgHw3qG;i&eaN?RdbqRijOLpKTwoz-VFszyyat z(2h>3Ulws-P70lEdKoDiF#88QI_~lVSAYBBNRcg1GsmB>dipE$nCA;z~jUpNniQ0RL zg7kn` z@kOjGaf*~LFbc&ZyjQw*nx@0#V|WZ~bRJ>(_?-TilCLY%IL1{QZ3#@W7)xI8ps;OC zzt^cTok#Rx-YCKkQQJ;ka{NE+ZLH=>5%$(PP4pQVfduC1@hlfd9@(>W6D^e}g7wV= zc|g%gsKPAQ?^2{}mQh6Nh$1Z<+DZbB#g3KS2OSXPz}R`?(O^sb6h$f=QzoQwVUl~z zy0%p#^QAEZr{^SKAlxs49C>6C^3UKAKBpwNQ-t$^NVfDE{vS>}lZkBANZ}w!g(Z<9 zvwv?CQAeQH{78;4Wo>Q0y=u5uq?TUhPpwEcX7brcz-8t}q>hau>Q-=4-aH8t7(Kqo z5yk)NGSh2*HkI(dd^TF`kL!|6KY(f|REJY$b5HsDdm@Pd$}u9)McoAGTRfz7o0=Azf3<39)qG@P}CJFJ>T zYRWANMU*^({I*O)z-X=W&SJGqbkQ$Nb# z5}>smc~+<0waA#YohNElO^!|+$(@v`Z!Qp%lzKv87 zWo~i)BlZ>^o$2BSPjm`I(Odox4{tV4h%zJs%j5&i>pT9p~E6sr_wgfG()LiMAuVP=FDKus`k?S43V$k z_GoWC?9qCpEUM*|*pGKT8q0BHVNa3DsxH;m1I=ms)=YiCQ@*Qbu+VA9|$7MEIXU5!|IZ&^H(E zKaxzRGz7v42qfN5^<|}(q!~~^AVDu9k8FAF6uA+qRRdt`s&B8FxIpfIZ*DqvJE?4h zy^_E%C}y2d+g@K129ccC<46NV9x!l<&I6akQg{TM

=v0hin*S$A1RIRd*p*0NHl zN3G!1m;$mf_6`r#DPrgy9cy}Wq)4)3Kl*QGZN$trsiTW@i|xoMRG=1$u6wpk!)VD@ z*Bch#(3D3b0hb=XqRELek}Fs-%F$Q+zv3gen?CR>h`X7$@|dw-J-}5>!i_-dd-g_sT9OC?FfDjn)cOKv8)<1n&CtJTNNae=C$n( z0Fmn_Yg#`onwE`Oo)jq>F#Dr?n@XjAyX8|}r0_@w%>F1I{r1-F=M%oifnR_9%b$P! z-Jho8w`>3V-uyS>^nLyhozU|CFzmlPKK;M%t=`Xn{%`^4i1pR}e;a^SF8gNxpXN8K zcE8<_tP3?tHnWpRt(>tQ-KNc<1e5F4GR4VeS=d@Q?C>m`E1}WeWSfb-Wst0K>tL?!-5GCX<`nC2H z1C_zDdR@#JQV@$-3!495n%k-zkpZF;FV5XHkq~m%K@?$un051Q zipV*WWWXb>Bv9H)J*dyfCb7hxplPyxN@|WyH!4>3GEy}9e}y7XD-<4){Q$+>B;5v^Mv82ki+4HX$UM6=6pjAh$M3Z<|CfLw z+eLX+Egfc${$GMs8!$ToMFVChplHDC1QeyiY!9lW+5NKxRq{||ah*IArNeCRSI)yD zv&9-kO#Zqki1a)QK~@$2*p9@$EvX+}-K<*m&w0?RoTOr{byRFIwf;K1Y=i^@A@PQQ zN(9jvQcGt3=2T;I|9->qzdz*vV+I%hf8Rg-|DX5nzkdh!|4jlVd0)%_{@won$LqIG z|6jRUE#%&2 fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" echo "<-- radmon_verf_angle.sh" exit ${err} diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcoef.sh b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcoef.sh index 93c56226b0..ee81c98c1d 100755 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcoef.sh +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcoef.sh @@ -72,10 +72,6 @@ # Command line arguments. export PDATE=${1:-${PDATE:?}} -scr=radmon_verf_bcoef.sh -msg="${scr} HAS STARTED" -postmsg "$jlogfile" "$msg" - netcdf_boolean=".false." if [[ $RADMON_NETCDF -eq 1 ]]; then netcdf_boolean=".true." @@ -246,7 +242,5 @@ if [[ "$VERBOSE" = "YES" ]]; then echo $(date) EXITING $0 with error code ${err} >&2 fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" exit ${err} diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcor.sh b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcor.sh index cfba7367de..2d1faefff0 100755 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcor.sh +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcor.sh @@ -71,10 +71,6 @@ # Command line arguments. export PDATE=${1:-${PDATE:?}} -scr=radmon_verf_bcor.sh -msg="${scr} HAS STARTED" -postmsg "$jlogfile" "$msg" - if [[ "$VERBOSE" = "YES" ]]; then set -ax @@ -239,8 +235,5 @@ if [[ "$VERBOSE" = "YES" ]]; then echo $(date) EXITING $0 error code ${err} >&2 fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" - exit ${err} diff --git a/util/Radiance_Monitor/parm/RadMon_config b/util/Radiance_Monitor/parm/RadMon_config index 908c2553a5..ae86fc2fe1 100644 --- a/util/Radiance_Monitor/parm/RadMon_config +++ b/util/Radiance_Monitor/parm/RadMon_config @@ -20,7 +20,7 @@ export MONITOR=radmon # you checked out only the Radiance_Monitor portion of the branch then # MY_RADMON should point to that. # -export MY_RADMON=${MY_RADMON:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor} +export MY_RADMON=${MY_RADMON:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/ProdGSI/util/Radiance_Monitor} # # The MY_TANKDIR will be the location for the extracted data files and @@ -28,7 +28,7 @@ export MY_RADMON=${MY_RADMON:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/Pr # and the succedding scripts will construct and use subdirectories under # this location. # -export MY_TANKDIR=${MY_TANKDIR:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/nbns} +export MY_TANKDIR=${MY_TANKDIR:-/scratch1/NCEPDEV/da/Edward.Safford/nbns} export RUN=${RUN:-gdas} @@ -67,16 +67,16 @@ export WEBDIR=${WEBDIR:-/home/people/emc/www/htdocs/gmb/gdas/radiance/esafford} ############################################################################### ############################################################################### -export MY_MACHINE=wcoss_d +export MY_MACHINE=hera export LITTLE_ENDIAN=${LITTLE_ENDIAN:-0} # # Log and work space definitions # -export MY_PTMP=${MY_PTMP:-/gpfs/dell2/ptmp} +export MY_PTMP=${MY_PTMP:-/scratch2/NCEPDEV/stmp3} export PTMP_USER=${PTMP_USER:-${MY_PTMP}/${LOGNAME}} -export MY_STMP=${MY_STMP:-/gpfs/dell2/stmp} +export MY_STMP=${MY_STMP:-/scratch2/NCEPDEV/stmp1} export STMP_USER=${STMP_USER:-${MY_STMP}/${LOGNAME}} export LOGSverf_rad=${LOGSverf_rad:-${PTMP_USER}/logs} @@ -184,39 +184,19 @@ elif [[ $MY_MACHINE = "cray" ]]; then export COMPRESS="gzip -f" export UNCOMPRESS="gunzip -f" -elif [[ $MY_MACHINE = "theia" ]]; then +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 - NWPROD=${NWPROD:-/scratch4/NCEPDEV/global/save/glopara/nwpara/util} - NWPRODush=${NWPRODush:=${NWPROD}/ush} - NWPRODexec=${NWPRODexec:=${NWPROD}/exec} - export NDATE=${NDATE:-${NWPRODexec}/ndate} - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" - export LOADLQ="squeue -u $LOGNAME" - - #------------------------------------------------------------------------ - # The links below are a hack around the modules that are available - # on the wcoss ibm & cray machines but not here on theia. The alternative - # was a bunch of contitional executions within the scripts to avoid the - # nco mandated log and error requirements. - #------------------------------------------------------------------------ + export NDATE=/home/Edward.Safford/bin/ndate + export COMPRESS=${COMPRESS:-gzip} + export UNCOMPRESS=${UNCOMPRESS:-"gunzip -f"} + prevday=`$NDATE -24 $PDATE` export PDYm1=`echo $prevday | cut -c1-8` - ln -s ${NWPRODush}/startmsg.sh ${STMP_USER}/startmsg - ln -s ${NWPRODush}/postmsg.sh ${STMP_USER}/postmsg - ln -s ${NWPRODush}/prep_step.sh ${STMP_USER}/prep_step - ln -s ${NWPRODush}/err_chk.sh ${STMP_USER}/err_chk - export PATH=$PATH:${STMP_USER} - - #------------------------------------------------------------------------ - # err_chk "helpfully" calls postmsg.sh directly so we need to override - # the utilscript location on theia to defeat err_chk's helpfulness and - # avoid a fatal error. - #------------------------------------------------------------------------ - export utilscript=${utilscript:-${NWPRODush}} - - + fi From 76c4945c3e44211276783a68898f39ca640d3880 Mon Sep 17 00:00:00 2001 From: Michael Lueken Date: Thu, 28 May 2020 16:54:50 +0000 Subject: [PATCH 4/5] master: Update fix/rev2 with fix/DA_GFSv16 following the latest merge. --- fix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fix b/fix index 543c84b44d..f0f7447ff0 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 543c84b44d6e87df2231988a55e0d2b25b3aa042 +Subproject commit f0f7447ff01d07e7d9b6efe017a62e26541751cb From 9541c04df277089dd2de8042048e8ed6a9da958b Mon Sep 17 00:00:00 2001 From: "edward.safford" Date: Thu, 11 Jun 2020 16:40:32 +0000 Subject: [PATCH 5/5] GitHub Issue NOAA-EMC/GSI#3. Port RadMon to Hera. --- util/Radiance_Monitor/get_hostname.pl | 6 +- .../driver/test_jgdas_verfrad.sh | 86 ------------------ ...ad_theia.sh => test_jgdas_verfrad_hera.sh} | 39 +++----- .../driver/test_jgdas_verfrad_wcoss_d.sh | 6 +- .../fix/gdas_radmon_base.tar | Bin 0 -> 440320 bytes .../gdas_radmon.v3.0.0/jobs/JGDAS_VERFRAD | 16 +++- .../scripts/exgdas_vrfyrad.sh.ecf | 4 +- .../ush/radmon_verf_angle.sh | 5 - .../ush/radmon_verf_bcoef.sh | 6 -- .../ush/radmon_verf_bcor.sh | 7 -- util/Radiance_Monitor/parm/RadMon_config | 48 +++------- 11 files changed, 43 insertions(+), 180 deletions(-) delete mode 100755 util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad.sh rename util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/{test_jgdas_verfrad_theia.sh => test_jgdas_verfrad_hera.sh} (53%) create mode 100644 util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_base.tar diff --git a/util/Radiance_Monitor/get_hostname.pl b/util/Radiance_Monitor/get_hostname.pl index ac3d971fcb..fed558afc8 100755 --- a/util/Radiance_Monitor/get_hostname.pl +++ b/util/Radiance_Monitor/get_hostname.pl @@ -17,13 +17,12 @@ my $my_os = "export MY_OS=$arch"; # - # Determine if installation is on WCOSS, Theia, or Zeus. + # Determine if installation is on cray, wcoss_d, or hera # 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 = ""; @@ -32,7 +31,6 @@ # 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 ); diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad.sh b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad.sh deleted file mode 100755 index 10ceb0465a..0000000000 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad.sh +++ /dev/null @@ -1,86 +0,0 @@ -#!/bin/ksh - -#BSUB -o gdas_verfrad.o%J -#BSUB -e gdas_verfrad.o%J -#BSUB -J gdas_verfrad -#BSUB -q dev_shared -#BSUB -n 1 -#BSUB -R affinity[core] -#BSUB -M 4000 -#BSUB -W 00:20 -#BSUB -a poe -#BSUB -P GFS-T2O - -set -x - -#export PDATE=2019061700 # binary radstat -export PDATE=2018110206 # netcdf radstat - -############################################################# -# 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_verfrad.${cyc} -export pid=${pid:-$$} -export jobid=${job}.${pid} -export envir=para -export DATAROOT=/gpfs/td2/emc/da/noscrub/${LOGNAME}/test_data -export COMROOT=/ptmpd1/$LOGNAME/com - -if [[ ! -d ${COMROOT}/logs/jlogfiles ]]; then - mkdir -p ${COMROOT}/logs/jlogfiles -fi - - -############################################################# -# Specify versions -############################################################# -export gdas_ver=v15.0.0 -export global_shared_ver=v15.0.0 -export gdas_radmon_ver=v3.0.0 -export radmon_shared_ver=v3.0.0 - - -############################################################# -# 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 - -module list - - -############################################################# -# WCOSS environment settings -############################################################# -export POE=YES - - -############################################################# -# Set user specific variables -############################################################# -export RADMON_SUFFIX=testrad -export NWTEST=/gpfs/td2/emc/da/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor/nwprod - -export HOMEgdas=${NWTEST}/gdas_radmon.${gdas_radmon_ver} -export HOMEgfs=${HOMEgdas} -export FIXgdas=${FIXgdas:-$HOMEgfs/fix} - -export JOBGLOBAL=${HOMEgdas}/jobs -export HOMEradmon=${NWTEST}/radmon_shared.${radmon_shared_ver} -export COM_IN=${DATAROOT} -export TANKverf=${COMROOT}/${RADMON_SUFFIX} - -export parm_file=${HOMEgdas}/parm/gdas_radmon.parm - -############################################################# -# Execute job -############################################################# -$JOBGLOBAL/JGDAS_VERFRAD - -exit - diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_theia.sh b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_hera.sh similarity index 53% rename from util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_theia.sh rename to util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_hera.sh index fcd354e00b..14afa518ac 100755 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_theia.sh +++ b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_hera.sh @@ -10,8 +10,11 @@ set -x +export MY_MACHINE=hera + #export PDATE=${PDATE:-2018091712} #binary export PDATE=${PDATE:-2018110206} #NetCDF + ############################################################# # Specify whether the run is production or development ############################################################# @@ -21,8 +24,8 @@ export job=gdas_verfrad.${cyc} export pid=${pid:-$$} export jobid=${job}.${pid} export envir=para -export DATAROOT=${DATAROOT:-/scratch4/NCEPDEV/da/noscrub/Edward.Safford/test_data} -export COMROOT=${COMROOT:-/scratch4/NCEPDEV/stmp3/$LOGNAME/com} +export DATAROOT=${DATAROOT:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/test_data} +export COMROOT=${COMROOT:-/scratch2/NCEPDEV/stmp3/${LOGNAME}/com} ############################################################# @@ -34,21 +37,12 @@ export gdas_radmon_ver=v3.0.0 export radmon_shared_ver=v3.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 RADMON_SUFFIX=${RADMON_SUFFIX:-testrad} -#export NWTEST=${NWTEST:-/scratch4/NCEPDEV/da/noscrub/${LOGNAME}/gfs_q3fy17} -export NWTEST=${NWTEST:-/scratch4/NCEPDEV/da/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor/nwprod} +export NWTEST=${NWTEST:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/GSI/util/Radiance_Monitor/nwprod} export HOMEgdas=${HOMEgdas:-${NWTEST}/gdas_radmon.${gdas_radmon_ver}} export HOMEgfs=$HOMEgdas @@ -59,28 +53,19 @@ export HOMEradmon=${HOMEradmon:-${NWTEST}/radmon_shared.${radmon_shared_ver}} export COM_IN=${COM_IN:-${DATAROOT}} export TANKverf=${TANKverf:-${COMROOT}/${RADMON_SUFFIX}} -export SUB=${SUB:-/apps/torque/default/bin/qsub} -export NDATE=${NDATE:-ndate} +export SUB=${SUB:-/apps/slurm/default/bin/sbatch} +export NDATE=${NDATE:-/home/Edward.Safford/bin/ndate} export parm_file=${HOMEgdas}/parm/gdas_radmon.parm -####################################################################### -# 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_VERFRAD exit diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh index 97d841806e..51ddcb8817 100755 --- a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh +++ b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/driver/test_jgdas_verfrad_wcoss_d.sh @@ -25,9 +25,7 @@ export job=gdas_verfrad.${cyc} export pid=${pid:-$$} export jobid=${job}.${pid} export envir=prod -#export DATAROOT=/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/test_data -#export DATAROOT=/gpfs/dell3/ptmp/emc.glopara/ROTDIRS/v16rt0 -export DATAROOT=/gpfs/dell1/nco/ops/com/gfs/prod +export DATAROOT=/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/test_data export COMROOT=/gpfs/dell2/ptmp/${LOGNAME} if [[ ! -d ${COMROOT}/logs/jlogfiles ]]; then @@ -75,7 +73,7 @@ if [[ -d ${DATA} ]]; then fi export jlogfile=${COMROOT}/logs/jlogfiles/${RADMON_SUFFIX}_jlog -export NWTEST=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor/nwprod +export NWTEST=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/GSI/util/Radiance_Monitor/nwprod export HOMEgdas=${NWTEST}/gdas_radmon.${gdas_radmon_ver} export HOMEgfs=${HOMEgdas} diff --git a/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_base.tar b/util/Radiance_Monitor/nwprod/gdas_radmon.v3.0.0/fix/gdas_radmon_base.tar new file mode 100644 index 0000000000000000000000000000000000000000..4e3ac88fe9bf3ff93dc7078ebb36020f231df3cc GIT binary patch literal 440320 zcmeFaS+?BBk*>?%63Yb!tAg^~1F6 z^FEHta_k?*X&H~>!!Uj)cy71-$LGI){4@+7e*fctfBf|0<3B$B^wVEI{dl`19sFsW zp1=I}|7Q4@31DbH^Ek6C6Khkyotpn1rvFn<4AcF;e|KHiL+hHq{?Z|L`O@iMbhd?P zzC$!D=XgB!*#Mo#^|3AETCQ5A>kz;?)Lqtjp6z%T#>ccQ=enKw>glmu=R7ax?|(P) z7|xE%c3kC&9G=U%PU+$nq9y-2{RNC)@Ydf8NA~stNr;)3@qCQ?mO$iiz8?EJm$x3K zV|1M8z2=(@=P|mp-L`{ml;3rH%-b|x*Aqlf@_(Dw$8i}_=7Tq_>cDiJ4uRflVT;}%+R)sW za?k0po@nyt;tzBSVG&k0D9k<^S7ie7kB!vvF3S2 zpFaQLobW&fn3&rwuKhlZ|WzF=_uG+i(@7v%;u`P}|`Om7cPKz(o zah;E4H%x2QT-#53tzR|t*f}foY1PJM+Ar7s*O5)Ul-u1x!!4w3o~~_AFWaozWX~!P z-B$O@E)(wZ3$Fh1#VtfnJo_BShnq2j=xDkeZdNV1y#;^5QSzsn7aY=nMNfwJ32SdW zrps-%b>49?7oNtaj+y9)P|;-SA#&~7_i@>6_rt4jnE398%Fm*lv~*-7Tp;=d`}sT3 z(OkS00w{(y;^C_T5mIE)su}7CLOoasQz?ny-8?q1baa=>kCuI(aT}%glQweB)4n** zUS>tP++(w%^sJfHHLGUaA>AW{#%4aTKoE62I{;;ef#$1b-4i#w)Bd`k;-tH6$K_QhL)yuzqm+lzZYq#x@$4)ujkRh?sJ^lT;V@5e!L( z4L>pubGj-7Kk~O1NCiiFYa@8!=r~W4HQ>ng>VhNJDJ5yK?2*gmYOr}O9J%H{U+ab> zPj4?AU9xhXa1>6@HtQ+Ssu>BFReL?pcF#~8h>V2eKopK=FQ$vd!BNMvUr*Vq@xCxP zG7p^qilO`U+70DMFjcJYh3MKT)dFFmz{tuL>nK)mHmj`VkISqyJ|dRS1)Q zbS-$p3fH|J_!-FEbQ~@Fc;?07b-cCg^)P#w-$nxH$A z!4a!ivsq8x(~c94R{VIDctXY}q_WNO)+9PwSku|o6gt}RT4wdMS+(ro&MRBA+WElu zZGdXkmU(Yh?e1Y`zuX|&_VX}5FJ9rIBkFOxOb9@qpdZIWw{ z7J_U!MjS1fAc!5oO6F`ZHaId}CS9dfI|%)>`jILmZu-&P6M>YtK{TQg8T`NwQR3J) zh!&_}w|J%iv-;NWG zSP9Zhbh7~*5!QxKTtA{Di^>;QIOl^%P8K;WM8^Aci-e;IInm&VyjDs*Y)4M#J#Q4v z<3>ktqhmECo%JS|4H_yPk-B2{lE$_n1`~iSL`El&a6G4* zL`Qqav)2p7x*!;B1W5~B8Xd7{=u=f2!A2;hK`lhK&GpEHBk5!{|CrtJfblyWouc%H zjuPcJ9C9bRZtH^V#|(fOI7AC!n_NtzC6*M~^2IGg#%T9xt0SuINg%^&RUn>?c|J4k^c0#&-P4pEL^2s&&bGGyp`R_*oL zi0umjl<0`SDwJ(%)ga0x{#SM^tF}7-NjQR7Z#cqAn2ti(@KSPD;82Dm68zBL3Qd9| zIQWqRGYyXH*9K7l9N8{%93cf*a9d1*252LdXLogM2ZFT45eyI>S$M?;9bw>Bjcpze zG^WZSS8_g{tRst37>O3234IQrFTd~)XM7@NPhO#Xp*g%BWua@?paVyua z$OY)=u8m;E`zj_nV$IH_&?c5B!v0M8keMIxrjxnvwAWCNvH{#e)bZ>9t5$Yu#Sz<+ zL`x%OmLO?X={)PoUba=rt9H-ORQ3F7h73}KoyB(Yy>{X$t-GIHf##AB+Ty6=*#qQ{ zm2K{V0i_R3u%V;-UV|CjqzEO~Vo@1>vXMboB1495B5Gkr zvY%~>4jWlx6b=|B(GY#NCmcbkhOHAfiwo&SoIsmY46w;HG5lzSofEH;70{AoE@~6GY^w&e&wWYPcoIWy@#bN0j}) z0a4Gh5$0&tzWX=i*0M?|O&_f08y#(=_1+*_(Ok@OIaqya^v=5b(M1q*29eaiBdZlH zj*Ri>vVi0(wn zJary$4O$loT=2Lxp3zNv>vSfx{<3lxhoHX@t3u-{C$svz@$3O#3w*?sE(%)7_Su~uU73trUgJviy_a`Ck1+2C>&t&5?Hz;# zZ?<`tfasz{M`kQ7M7E0rX~q%RGtjS&`K*$=$70k*pN<=4D-pF)HZB6RyXh=xt8n`R z6itO6vD~CjqK0Px(F7?8fPw0;g~&FQ9uGvXmut@Z3Pg1Ipsv>yQ`&eyCs$TIxrCi0 zl=!M)6W;mJPL=Of-g0{2Z6ef=u#nai7ah)8JxYg25eO*}a*Ly$XVVhsYW$F(8Lr|C z6K8J+QMClpGkF4Wi2O|Yj$l}Ahu74gEgdM$`KNe~f86_?I8 z9SE)Q%SP~at9GMoAlh(;m{4TZ@FwBd^S#E_I!)>cM_4My)9$xjR3RdMj_=DM;+L2- z<*)!y>1eCgQd%|Sta~ERYQ&$CM+?LN?@VyZc$*-CRb=z6(h10JgTs^PJ`ui6F{iWF2uJzloGt{P;|JLM+=5ro8f9kvkJ@;F3SikBO~L+I4S zn=TJTi6K@TAz`d-82#_N_JEr?)8na{MVX8Niw%MeM2w4cGkRh{AWYdCxF z5aGqYK}0VIHdlToIO3W3ek(-Sa;6LlB1H$&W^W;~^>BzT)?xCHk|-NFU~o&xz2OMo zYYUMC!)^{bC|liLM)&#S=|vSNPXr?5FnYJ1+(J}#YI>`LBSnXhKIscs_=-TUnm^`D z2azmbVE5Pk{sXAHDx z>sIaV^JiM6U!5n^#OTO{p5m|$HsR@5s=wQ9R;8$G$j(G$-`$wSjJf=|6`suaO? zxUU)t*=?`k3_+6VA)+H3wFf?=%8yV#i~@jYB-`S7)r=dbTj(~_m*T58aR*<;I&z^x zn6-n5dfR6A&r}{@-0NnUvau94#}R^-_?7c)BoMCVgpw9VM#AY9x(#d{4CF2TqS4 z(hr|-#A~+@(F_vji0^*l+W2Rxq}^~to1c+YlV>Df+(Kl?(Bl(jA8c^=gpT>}hOD>g z7Xu~DcN|FvZdQ#VVw|5&N5Tn4qtlVn4I3#!$@Uv`WF)M|$JqUbi~BB(RE87XC0N5`^H6(ZacB%$Q9K*Z_eNn`U} zq{|9KCmATl$`eGqYQD=`5ZyF3Ir(9+`D*%>VIJYFbsSA3otc0FBINFsRmv7ewmcQ0 zPSVw zd4;l}3@2sne%!&vN8f;`;gELlS4KEIna^xTC zzAcW7X7zp9YY?xyXGBNnRsWnH)vOJz3;YLJT7*53V;rM<@{F=-1SMb$>t0rk9vx&$ zp}2Re<^Nh{Ew~&vuA|BeM+bBfi^Cuud{VeG!<{2d-Nit)JizpzC zbGEi+Cy`l|554|tXa6>wzMc?f_2=?x;%#G78Hq8}Ei?tWmetHx_< zN~y(lz!7==q^o2A3AVHEz_+7}vIMra0BBb&9MAUU5u_sfS(MXcXu=B?_?%AjA?n%T zs8(yF-9+CAO6c>&${M3C+j2%z8sj;x6-T6Sk)NQ8TO8SX==%f_6>vmF4Rr)ssT6k` zirnTKL<@=kw^c*pc>Nt5lJFmO&c00K?7-3VsKk$0(9%hug{bG*GqnubrukQik-Ks#tc}Ju!^KbYk&l=CS#m>I%vmMjhPap z?Djm{#f3pc5_j8&otz8GQd}FM@XBM?T6+yy>mVX!vd|{13;qM?IUNzjMPD(9XtY6s zO3#lxXk8!*uxhp*aUe3r69*z=JO!dbT>$8oVqcR8r_L%y|Ku~>DVyxaI~`GoZE3=y zY`XAF4IRPIEoo1AwInM&Wkh9C7dU))ZU8#!cy<7Y!tre5X0~brl?*UJX9`N~MK3f= zPEGF&@gr5J+~_D})t9$~j!5jKEZO-HL!i;<(z8&z(FD=pT-VB9Q@D`-BmE6QN1k~t zkYYe&>T7|BdRpc0c(1Wl(@lLw5%sk9{zodFy{{V9id7Y}YEooU9b{6hNefoiSXvLQ z8kX2|m5*iKrK@7#C>+mrsa{s?_58?m%s{JVoF)#AqVa5$%(PzlPlUZjFT-#U6|FbH zCFm$9Voi%jH3&!)7Eq|$sAdku5# z$qxw^&F9nK7^@ad&!&DW9F9z(7GN<}t@Dk%T#C>!<-Tg_5<_1<58%+ik!}xG{mDqX zTCt+Nws-ZkIMgw73y-670aiJsW>ts8nPl+;*&-@RN@SyZB{n_(tgQM~@eyBg)RG z`zSnFS}l5QU*AvZlw&B$s)gg(UYRCTiKbFC%iG;hn}yuPabGZrq`Y||h!x!^ptkQ;P4Pr|wEig&5y0>g3E_zTOvbgo3K1o{<+ZsT zlucz;>U#{aQ_gnLIHxK1Cn);Vi`DztCb%4;wxUkGg1;RieCEvV%5O=JAT=nq9^SM--uQX2T6YGx9X1WbfjLaMw@_urau~HoKomB^I*JtLEJS z--5{f+bMQLf41F}borsUlT{rO55zN02drk*Eb!ezRH(3BHA?k-nS>+aJ6~9}4kFrn zm}eBEP}N0gl&u=gkx)nKs?qR{#x{C%3z2b}vTCo_*u3#tfk-?X9C;ul(~-%}udEvD zLaz+?Xb~l#C3y>QNROTn(7Q_! zb!_tJx*kFgILjfB_6ZPYStbI~)aBD%-|2`@O(}J4A$sE3^r&ilZ0dl5&)u$i?p$%7 zmrW3qH*&33%^?Z5XAlTMGkJ){dJfUfT;{(25nNNtRX*a`q}5PoXu^`<7B$hO5jba4 zqxdG4jf?PBPm3f~i?)0}$u-8tG+h}ewD<1dl51+ZmB4Rt)bnh%132%<6pm+m@-1q(&D$=LBs%2sz~wLeKW*bOI^{MB(&o z&*6=OBlA?pfhZi$cCSYq9EIcA-q$P)j>6SJ&gSVAiehj`%a#rVQ8=D$v9Lfm3dghi zI>^^s*(P0`n10qq7Uz%02uiA=gis+g8@Ig~C zX=cp7G!0(TzdA*)_Wc8ib=0RaYhl?xFvf>us1L*VU7+c1`j5|l|M+PbKK%a2|Ni*t z$H#ws{OPB^e)_Syh{HdP)AN`A{@)Ch01`t;e@JU$tw`dt1UtUHr*_sXi)5?&Pa}9X z$%S!vVt5j$H4g_-G#!xo(Qr75rUR146%I$84mccSJ<=M*P)Bu?YQ*hO&6O-SPdtPX zQnx()h2znB{ZU&*hXwk$SSp-SQfVQTaX_9vhb2+E+yyZ-; z9utM@v@&i>l3jV(k*@z_(d8$#5OsEY#t}Ku8MQ;g(dC(;;K*0$%~hlS3B6nLkChim zuZ)@qOEJaj`Iq2`B*2o(*+SIu>_SIYNS7cYlig7EwN)dBb@u^v^i(0klXtRJn@BeF z$sX#d!hGJRImLawM}~+-Lk*6UdS4E|3K3If7^j-AX4Pm=Mx~%bL^eBVp7|^gX&zlJ z$Zc_CB&^G{g3wW#DVcu;j_Axq{%tvY1EMAeo$;9TtYS)527xwHLPF|Z#!@gCl1yD@ zDj9%efU2fOw{9Uag3Ptydf2PpAgh0W{^Q^O`nTVGFB3pY{x|FY+lc;8`NQ(A z|Nl?WMA82X0cacZ`BnP=KqVb>iky8?|HG`<)%ZKTvTm{jVS4YYL=h)r$uc1H(PB0+ zx#z})7C8?Myr|3E}t8SO>#O$Uo(vPRQKZ5myzyHF~0tBa$c zig{M$b-)obq_Le1M|4tIyblz&rErH?!FDhGt4}XWw)F%@uBxaT)=s<4d@tVJ|Qt^{7aY`bbkF#2Ba#w()RdN@yXPTNMKY}BV4Wup|` z>QGp7M)4NBGoP0KrjEi^jrN6g@-ccF1z61E)RS9?O!?6FFO;`>eEFExs>2u%_4+@R zf2tKWUj}4>HQ>cW6ma@(7pBopZ*?eY7J6Jo&(S1SDVDAlF{ym_iZG^GqSK*h3Kz|) z`KHqMiH>N#hWcfji-}t59cnw0p0U2$Geo%+oqnyo#&|7hi}`Q?BD`ugcn)=t@qo=t zSM*v96V=5nM1sOT8KM;%q*68zL7hhbK;)gB-h}9)wQU|k2xFlcCvQ_r^BBCzY~X_a z5qROZeKq6oH20QOLnn2l2uBqCREVZjKBRZZ5LKxn9KpI)7eSi8c1VAIHk&ANe(nEr|w>>)A=sSqv5R&Q`1%BGgt)|OrfH(MLZc1lk?o6_pS^l(r;Xs)_p z0c40IoYdUdQO26mrZQ1%OGozh1`(2$J9&Ft)Humq<62KrgjT>Nc@snw8IM*Uja&mo zND9LdqLq@_LifnE5!*j+t^e~sp(*|Ed`7GP|L~nc0KZ88-{-9VA0LKy|Nr-=xtsp~ zgSIiBU#0)QJiF=L|L?{_SM%C%?q2^7uxgzw2>_948`={{)c_EgB#i@6r~eOFo0@NI zx-H`!BP5V5P~5KMs!=+J7LP|_1MPL{8M&*x@Ain5jreXO%mk*eM6VF zl>My#pA%kZQ;X=@OxJJIM+YEs2r@)>{hwyzbe$;o#B!h+Hx1%UC&3v&1M@<;Qt~iu z^TiEBZ|MJ*dg>c_(a{Rs)*CL+J)zUv?!AogdEj;~c*k-;C&CYH5aHa=1a2WkDi!7_ z{)iq&t|RKAtlP3`m$y{FaweAHrZ??T+*?sr%~vr!gm^JC33M}Qk~GDqjk@b?G@P06 zSmd*)=0x|=e0A93$S6eLXNd5SU~uc05B>wJHisKBaR@R*^sH#<2n69^&%ebRrEdI{ zj<9T)nq2l0t0vpK?>qmN{?9-FJoEXcoTpF1;T{rNB)i?1AtJ`pK!g{Ic_jr4JJuft zer@rxEzIVy$}TLDeL)5%ifwW9tpC&Vq0UoDI0CE!AcWE3Xm|fa>J0=+)}@%T+5;D@ zoXe_h8mK{wncB?+2M`k&bn6zP@;>Q_Joi-`^84#a|68BX>i_>4LH|Ftr2kLryZ-+_ zL320#|33@o_*MGf7-ekU62ei3mJ+Cw^*k}RP&Dz4(f!{lK(VbAU- zK@iEoo^Q>?2q{`f>agKT&;I`zSwiR_{|x6lN1IDGx@+Au03s4De+3bfW?+4V)8Q2- zxQ#-CyhW;VRv^`W_|r;|Hy3-h5Scn82=s0n^CIv`8v9f?9;P*z<^n{H6Ws;b>JX-9 zUd*1c7zw^Y28N&#m1buqTC8jprD4W4D?lsk_ zu?P&CafmMTTyh@`qUB)jlg=hpywp*5NVcM;tbkannI` z7hH_)Sxykq9dNWYMz@()hS<2ajVGBXNr4wllHd@H@${G$BHL8@KH&)6s+k!eh>m$N z?d}bToUQ~Bsx4mV@;bZ=o&7jA91#d)UXbhm#FT03nFykV$Vj+>2p!K0)dUgFUt3!s zatPkS5!o|iaWhJ{Wn*bw3?elTL;KdF1U}=CE;x%08i?M||LJ;5kWSa}frshn3pl#3 zn(}*WjdN_ZXsA*-YL7Y+Gygo+trFj zV-l@()rc@NB_ZEhRvX4b-(l@7{h#?3MC=-f7P^j=!;PTE9ipmzXVPE*k4=v_=nKAS zvpF5nln(x35D_Xk37YD#T{U}_zArdh8vnm28@6UwF>$Eh{WtwziELPE83fsp#Ep_% zW7!F8B4}xZZU6!gL6Uy=o8>Ej5=5k%@k}pwM$BPr8;6k;x#5V+xdtL+>A~)|{XHS0 z3BFlI5@*@%^n*>$Vy`JbxeTFu_y7OPs$$mv|H8<`@0R|reE)CG|G`zD{Qq@bJ`C^v z|9^Q|zxjtn|AzqbzDj?8o&JyBK*psd#SS&xhc17`CmF4P{#uwU z`ad0DY3%B32vxGp|AGIa>sn{eRI& z#Ws@$fcyqtg4_7BGWIy!QH`@}sfEZyy)F~yCMg$)jNyYL^Z_zd@?C}t#j?c_4|L5k zJ#)p;XcF@zdquP6q_-JFq)}Ih6makR&_3t?C?HN2f~j*1uT`YpakSi5ZKqPlq+Nn& zM1WcsZ6pBkfBN=kh;S@&L>7QABC0q^40_oXN47lrKI4dowyUP5zeXA0=n0~m)usv- zB&=@6?H+hVF@!vv4L#CLxU7ooNa~UL{-Ibo`Pcatuk&s-P?++euY{w6MzQFmCh~a) zkng>E)gRqfNti~}y{#I9Drq)bevCJh6a`4xmWe^V2xQkuh~<+3kPh2bGlFR#BDdXJ zyyMmcy{2nXMbtxdI)tJlR)Iw;&qV(t8HYp(g9s~}q^iP6xLA4g{j^}L9D!0k1xIKh zmN>x331*gJHrW+lg9zOgV?AH3slGE4DXP^5$|zaLXO(EPZ_mn!I^cSd}}a@$@Bs3*&#>} zG2YE&OX5m1vchyKMd~GCr6s|N;M{2ZlX)yTWS%DKdk<0JS_uHj05Ti#x4OcQ`;4jT zCLIKkOS23S)Ehr><5x0$w5!(1lGp1bz5YL(l*kdMG1P$` znKnk*C;+a@>b*3oti=)YO7Lb?4M6n*m9nwF$TM->mLilBpIc8yrfukZoum%*l9yb^ zeApbsdt8@djDy?Of(YB&Aru`Qn%!*ut?{;#+75uW*9b?jq^>2Mn1o|iEZbGHO{K>J zQGiu5WQ2jpC|>~ORlBg~;biFxMYgU7#h*r2j32t~HAu{lwQ8C#35&`E)frxA(^V{a{^w()N9qIcju?;YLsiDx58_Iqw|6j;Aq$nOqhD=?x&fAVg-{J^Ywqjd)2xhw~ zu%c}Wtk|NT~ zE$RfPIx#>j)+SdF0rST6rmTfjIo-E~sN>m45$MQ^J(8rwU1t!?n|xa$%lO20 z5)~dHph{dxf66DR-{rq`l6S0fk4aU7AXO`#i}K5}`FcvYby4K}_ZFYY^f6LoX^nhTzKEh zd>{mJz8BOW1?5?{HS0&02}i6mck)Ipq-7H!v1d>ne5Y)5^BZN8#x_FA`I++DGEA^$ zw&A%~9cMm^?S)Gc6-b9IjtYj;Rh$f5C z8$XgkXOu3=hKhE)#R=oeZAUNK4%fDoHAnm}pGA{It0a?Ohs~-z>Hn1evYYItf(ReJ zX*L5M54Rh27d*wTH3=eAMN-QOWh+MtGq1@cQL0PjkTeQ_L8gmah!SCCs1s#_BXw;m z$`yK>iUFJ%yn&+|ha?0-GD)HAg_j{JQuVf#Xej}T{4@}{VwFDkwkhY+Re9Cmki|~m zOUjes8ov84^3-gVGL8=CPifUy2(N@yGCMCgRsEk#mZtv?7h0&Z#Zk|*F_F;tjmZt9 zWD?f&IMUU`Xfs6j{D1r(yiIva)N3N3EvPA!BsJPqNF}!$^ zc}xE{=9Dg&8m^S&hy7Z-N9}u>ENSt8qa+S+mL_61d8-Xyxf04DVN%!s(InNPY%ALK zNq#V?Jd>v=khnRbO6%z@M7=D*y`vkOI;VVF!s5m!i7DQ^Te#C5LU+iX(z6q(q_B zXU4da2SH9lLP~-NfKWd52BcFxiGq{_YP#v}qnUv6KW;#N_u6bl6HVZx%b`)M3 z1PMnFk{u^mlJY~#8k0vx;uve5K}f{FD-;}Xh(`7X9T~wi5Fuhcc|s7awa|sa6knwb zk$Pb?RvR{(XNo~#N@lHj8~FQ4Z!Hu6M06)Y{_4psjynB+pvD2;v6+JOBq2iueM>*% z!wqf_k!0Lx06YZJEzKc8Ih%{Fh|SbzgfDtgzLjva@_$czt<(PpOjinQEs#OTgn&uY zNfLZ$bLpmfFDXSL_52W0*?Wg-hd`>-hU7zbA(bPf6x;4sF>o={#46zL*gEOr z7Dr_-HV{!Fg!!Lus$~L67HJs}OC64I_cu7g|A2B^cFT%ZtRzw=Wz<~A$n8kzb758W zq!yx{XHzqdW6KOLf`OFUke*rqqcMc4-^^qx=SVj$JlIXt`*I$|um;YebvxYvav z)wt2cwTGzZ**s$=mDL0=rZj}$dkqgvhoilrBNd#{YRii2l_N!Y(&A!{mT@~g(E!9Q zmm92y$lhMx3xUL%8~uV31TybDc0N$QbHfoaT&JrfMbfgAb&-7B6@zdPXt9J1qDSfC z8B+(*t%G*edY-*0|A2;5x{i{~pblFc8SfK>Y1LLJ1x2esOg#Wh+tnqqgKlz-RKEry9IK>K zU{2>}B8-TS;_l;+`=QUVYFVhT1mH+Tq)*X5_r^33iH{hd>=eOg%z#z9Q8rS|AxsY; z|Cp-B{5ldwIBkq)ykKk{h6#B$!N$ompP!|jw57f3lXL*3sZCe z!Wk3(?KCAJJEjCxF)@>g{aphf#_y!qv~RbnYh!U7z7DN7-@E#EJ<~P)-W*Ya89ip2$CF?Fvwk<^x zc&qX=iLWTN)*O(4K*^L>?#n-=2I@VI+=Zo^6o@FdahrtVIGio6TB<>o?X3(E&CB>A zgTOPfBQZ7|A_zJAZ25|_bWg!Vu#2&NNOXOIsQfxzRUlenZT2;oRR;at6EjvOlA?CL}1F*{-^s3Y%!lz(0M!8r@l6xYpBZ#j?`S=i(?ORZg$3k9Al8V0kOkhXSg0u_~ug01oH}hGE90X1#^adi^sp*N@ zBS1vd$X!{|YH8?al)XUY27&H!hlqzDY2lI?{_IDBm@^2lR`S7dnm9x_;-34FxGtuf zWQd@n+SQ60brSk*Kcm3atdR`Sy&nmJ_P|4F5UBtf|CNJ)-;Ji4zq*oF4KNi&VVR*Oy-&(QX_PgOm0C~T^ng4q?VH+-x zcv1Ob)=Eh8$0jvFjP|FDAUniZ5u;2ZRd>PAX?QpL98-}PTfQN2TePHOcFj%7F0~!` ztRyb+wS?OBd-KsvRit zc{ei?2*DPe1&t8!`9@EEgHyK4|Dyi?-Tu%0Kj-6p|Npi-{q4Km_Wzgq|Nnyhk1nH_ zswj>RC4_hbs|}Eo5`F)pGT(NaR1HrcL%6?-1<0!+l^ZidMF6k`}k@}Tn#i@nJ9<9r? z|6vhW*j|FbORFD+k6$#IZ z-ap;{f1z^h`y~L1-4lNQXY;@B`+v&y|Htya|KHxRzwNhW|3d(og45r({QtjT|EHL` zHCGz2D^*Ks?0`J?yZpy2YH3?FfZoGg@*mk(Ye`i$>E1Z@|3t7mJ3QLm_O$=;PAkq^ zUJ(}~DJ$mpOxlh?kaim}emj=5Rid$5`J6%ilVfGO4bzi(U~VbVl7#A=wB1{X`u$IW zYn!>Pj6`}A+f_7Tb)4uf!~^d8pO6FPLiu&TE;uE6ZxE?jF$^T1)&2*-(vj?$cC!5c z3to^Q`+rXPztqOQ@Bio3`t85*{crnIWb-TczxUQh(vjC6Y&Oo|4vc zB927j2^nqWndC{~%_3%M5Haeq_1rRk17}#e_zn60pPzpI{JWn%fBK#^0AG~Kw%XGOv-ZQo9Ws7dViKcb)3ZElg^N+c)D zG3c(AI?(pmn$5DYpn;DiMLB5*|9xKcKLDPlg}*@~cY3QOqff}^C`>R3ooJpkpScBnXr*IPhk zB;OM~%V#MMphT3OEIMp)Wb2{tW8kROWVGNUpc1e$mm=*osp32>qR;MEVCP0hxCiTA zBQKMnU)e46Heow~6yIxj*S!2f2o+T(_S4|VxPwrXq`!*K;YVdZ(@9cYrObu^BA$7J zh|EwoGGh)krMaU{AYJwcIL{Wxy}SV1l=XmMneuZuDr(V>U!rDHx+ zr^;t*e3YW?q&DhQfe5EgeQh=q9_YH)NZD|wQqt(~BNcpW{ud(Usj}rc{*M-mi_8|2 z<``t@RH1?z)vsDxwSkdH1F-T;WfG&vE+r-@h$xD(jAiIZi8xPotu3-%I>zpI9lAio z?q`u294R*un>|4c%%l{VWHmavQ8voFx5W}=A#2uEp*m98#0O5?wEEEdBnD-pvE zCAQg|c1Q-Q`hVFW{GF`QY_a9<^w&JP=^M8E>*?qz{~u!=)7sMaSXGMu=z3V*K`hNU zV#blUSIZ$uNHSSTi*6d*;mLBjMv4q&GWlNYHMDN(T6L&-M|_u(i@%)olyUiZZ6qRycVq4 zA>4^lo^ry(m;4e5ziEcVh{D_d4XD)*y zd|LQn?5x_9k}_q7MCc~M>^f|5WHhVqL*U3>KmZ9Mab?84r`9PGQ2B}JJZJIa8~;f- zA|t!ivoQ%tM=V4rI^u3s*po;|46c#=3;Qx1HaKz;E)cz*XM5D6Km-=ZjAd68q#(RS zM`i7m^NP;f=-D)KGuuRTq@6_*tNdeZ5z5hWrX63g*GO|fjm&4^M`V;!=d8mPM@GW> zJ_a2<@oc3JH&!I`PvvmHspmXo+^Lw=9q1gaU_ma@Gk6vg<4im0V!Gf z6-Vm1^<-r`2^WY0?6oJJO(qT{yT&-x1x)2o0+^3d86YFy9}--xEkXu4RW;?FYL!6s zgY|1=ui?eSSjo2n_Y?tve;u}TWRKSOA@-WBssJiu zxmVR8DPkphQOSY)M`S*kAIo-LMfbnlHotccoz!cmBX5gg(U#*Y|FLVAnuH9SkGQ;BR^92xH` z5WRk{xzSM|8W?rNJlh)cC#Mg2ZgAtsyk*&Anz*Ml@gqWLrL~A^Bk=9u(sG_n_D*Z@ z;@Y9W(f6$&;NxA-bP$7%O!Fxafg_AmZ-h6fJ3KteWDO3gTU-_VZC?=|XDz3c*IN@KF0dbPW_2!kWz4hbb%e~M<9Lgo$%*er!x zu4&5C(c*}5RL^cnbVTHfI7CJ;*o2Up30n{){dZl5q(G5yeL`qMNA3cRgQK2jlco&M zcC|^7nzIH~HADP{qi#}ztPQ4^IF4xY({yT*xm(&Z2%!|u6NX3^w>UE17Y9eZo=u)5 zyP*0ZsXHQ(*>o25pSd zP^nd_d0ILO$Fof*t~kQVRPV6-nq(m2aKqjxhp3P;*IZuH99(95On0#4h14Q$C0Jg^h77)7^Y!xs~pvEqP3?u)%RZJ z*+i%;fJxv`oujO96D0y)5?zb+C|!(yjUZ&&>P{>{H79DBs4705CdMY}mEd&i- zT=p|;jjjlVP6)>75y1sHyn`& zO6^?XD5^P^iR*dnFmMeW%J%}H8oQBi-Rw29_R>``aMbf`oJC~!c^fpvAkip|XR8@z zOGhBo=_=8YVoR1iL*BAFs8&BDng6(#8ag5>_0)gF{lY?03>+DAE)ZeFDp+lSLL$o~ zcQN`Yt*Qdewc1c?k5cYDJc;u|JyQy$P~lDEOWGG2&sIwW&z5Ab(XkZ`Nw;q4C>+mr z4O)OQ6pm+`E+aq_j&OvaCVIC|vXN-e{{d*LKVN@e=Fcs40Ugii8d>ZL+{ zq4R9=$te9RyBkdv`Xnhr7q>VveO2Fw*lV6uTp*&^7=B2SeRa%dPR)@$bAl=a=RbNc z4LC6Vl=d1bA}CEiReMjcOPd7WYpO)HUOtj*STWh{(%{IrS-M9I9Q8aKN2A*NnzGAy zZg{r)bjZu%~9M>PO;T z#hcgSC>+oBAdy~5??#%ZLfMWKdh8>7O!iZyE0nmshB9=+(Lo9>)`)JFeEzuPXn<#X zjTkMV??PqJ5eg}I(xokq!trd^pap5h5s4vKRXXNFCK?*0qYOvK9Y@`C2GWUP(&fi^ z3=Wbjo4rQ&BN`FpJA)(IOX1SiVT+@1JlniE3GRd=3Op2<%`ZYHFys$=!VbIHLu3Nn z=!m}5Ou%!Vjc;3$%jk$W6WL8g>VYG4sWLvU!I9N17(}m+uQ|a8B;kk@_7pozAo3Nd zG$;d3R&;?j{-gI&e9Vr;acJtH!oK`tbqFLQ+&X=MY=v!YuTgoBGQRq~=Hfy(0ipmn zGJ+`(>8;7^H_@cBN=^AN9Ff*`J0V7LI3|A44e0Je$Zh9zr88Q~_M97FAS6sqZbl7oLy?N63E0zmw&d?nW#d z_qICL7(c=XfG1KrnvXUnN=42rXmMn`PZvelYZwj!rF;avCc3Fhp?xJB;kvg&Fkp0( zaa8>PdTkA*b0;QM6r_mamNXopo?_(|Dq~}=OvdcxT205$BV*vmI8A|Q015QbtBJHk zk|=d_l&K22(T`}xcC%^em?D>V#wfN3JeprSj#L$G+zK4Q&&!a)N=KzJLcT)~9NDIF z9O2+61JVhHyjr>q`XRNUcN`t=2M`^RdyJ-C?y0%sI3;U*P4#uo(ZLZ8JnPI-a02C6 zMNaxA1|1m(bsVwQ#50U>szaql#FTeHrM$_0#*Ezg(E^GrM~l5i0Ucd^jgBZXB3@Vc zKR8mS*M7n;Lc#GBWv`im?>M5miY_B2$kf4uX$E$cst#K^QqKcBPW*^W8t-1MmX*{9 z*4ZpXC$WhgM+{~`D|fplqsHrl(_siYvf2)VNChJ5UTthjeMPa(osMwZ8&1SS)Uv^j zg(J2Sd$s&nzfAU<(UHp6Fh(*mq(fpHW&j#~WWE!F=;b;jP!@>wkGKww5YlQrDT_Yl z4+eD_KVo>y4M+5lx%vE27#Rmvu2%jL4U22uD^#IIbf39lML=Du2b?GjnCCqhSRJDQZK zmX2(jmsJZuM}~|75k@S#tC4F;<1eEVxJ234hLeON=)#V58uLP_YPy-45K|yR+Mwsv z;!&f6u2C*}Hj`QUoKdvY{Oj~L1|1oN2qf(hO>=9e*Q!qh%@f_7)bng&LpL1JiK>)0 z2uI{s5N|7VBnCuZ$?Co%Fk*$JEgc!ZDiFP%j@)}@I8sLeO#;v{AGQ`oZ+?M@L2M}2 zB-rSf4@VeWrW=E!B*rR^$d##dB)NuL&A2kY5gh*PJ(p{+BSsSBJ8NT#x!bRP?C=&90)tLnx^@QcS?@en?l-) zTY)3k9@>~TOcCSon(hD*T8}6(X`=m>Tf?EoSY!#>@FS1q#lewr z<2Vq7L8iqL4O%*7(^mJzD0&C<+UGh_&D8Y?XT2r z#GK+v-N#8_JWicTPFiWWO-nsL*#NF*!Df+MYCrGmh-J44lc%* zqr+zRdseZ&k3rdnj5rW=zL5ZQ)alvGq@;}})dRvAAIdb*A8bEEN1b()hco)_SC3xL zc_m|*G*v2LO^UGD+bj*Ga~9W5Lq~lbqT*3q%7AXUYBYf=yP9keycp5SzNK8rg(?EX{wBtHJs$YFIIS!cO-@5W7-fI<1Gy z1oDE(+S6gXY8C(~5CvGZj%N>K2`K(+fPy13D=KBDekYld^B!|nf#~&g`Lxf+|cDhdPunK7a#H?rTIAQd8pIZ+OzV?IDMV|bgUNw(Ha z(q5_Kc-6CMn?-kwVsQbHx{RKlS4$DoLCr|MGvL!O5CrJ3g(w`)wwP*yJA|HXb&>`V z9(HMsp8kB2M!-lBTSVf%_f=~=T#1fI=EcjN?nY>MVO+u9Ocz5tD&vIG#i;YBth%^e zwQxM!Nm!7^Sha9G+X<%NXi!=z?FCJ-R?;eg8sGi78Dl!Dwa5N;x=N%$f#PVT_{uh< z$Z)Fsh~z4~p?Xxhm}K(OT&1C-r#eW*Ao-t+0DY8O1KTj2h3YehAVHK=%PUjIY(Z@@dOd@TV7jQh=n|Uv!j6s z9(}A8BBn%;N1{iii`Aq(1JL3q9MASBwZIOs`;ET}pdb*1z}8UqNh-_J?(cXu5D{naFrpx$ z2E;wObRu&I5=32YjoP*{TsXZS`PmfBPMB5WYa;;3dLeB=PK^_iQki`%_s+g#sA zplq~Gfl@v(AQGRpPYj5n`9>%)F$D2%3>=xBA;4llWO_y%h@$aq{LMm6`DovXXRE1n z`AXUd{#2v?XAW5{N*Fv@^{OQ(Od94-lRZ>4)9Fk#AW!O;VkQBfeIQ$!f zj>7Tmz7F!`9xd~O7_#Mz}OU&&6G6L<;i2~BFCJ+X(Jp^cARNbBRJG7 zLwa_S{SzG$uq>Ri!AD`y4Q0F0p_|0Oks%`vMB#Y0cmIfkqmE|>*!|&nwwu#s)sSm6 zoM3Q(j`?W!Q}olebR?~!ZeZ-s|)9ik; zWb}26-5;(Fk`&H_o%|;Rhjc|K&Z>pu*;b94mMzArh10V=Dinu~j1|U#$hdKVD0ypC zoSX#qR|I!*3zvTo^A2B z1V9MNwmw^dAPUE`-NRVu==J)MlW-h}!s*!-r3ggX;q>fqb&xcpPV1Hbgy4`K{tUC% zOa{fFZ1?BI!I3!}<3MC;M;wU4@obNq$H7rJp550$zFr&gGK?^*7OoDGc^X1a`Gk;b zeI4ZM>BzE95|(1%C>+nW9-D!16wWu|MWI4c3_1$u8?id7ICSJ$GhtROTpi^6Tn9;9 zfr%DIUK~+xZW)fmAiI3XJd&m6LozbKizvy6!n;K`#2j?IXev%4vN|G)Iw{hp(q?Zw zTHcGYtQtNxjqmW1EsiLj^dWlB5Y?Qm`>sm!E#7HC6&FlN=E(AL&{6;ovAq z_EYdAd@+#<)!9``1|^VwXthF`xRgo{^aIH?1}LRqwvPFrS<}JWtO+WMXarB?K|ZMw zCyc6aPXmRUC#6zpks8gvuY(+@6Qv)Yt4*4_ey*M%Md6tD%hp|12B}Nb=4YllL&icC z%^!$PO2;h8fyScbN7h-lM*O;*FnCX zXIpVObAdbX0z%vD$sU&lKpti>{x_I z6%B3ciX33~BU@>}OpTLazCk#V8Qfj>d5yN(z&} z;iLa%BocDM!)^@UQr8fpBNQ&z(6shYg4305fR4t5Tz4kV6wfbKBtz3o`h=X`QGo1t z3R?Occ7zZ&vQGp$s&hI7RSbxt`Lk;;fjBsd#m`18mu&&c`l%j!7Zu=4QVQd5@TRzLhGyYc&oXnYI!KqK;<|3{Ixmn4^wiOmtOqA2SM^+xgP6HrkiADJxLA%Wd0)g? zHOo2)1d(}$1X76IAFd9P=80*&@}C$uGK)UWs)gg(;p!llaCMMNxH`x(K)dX>5PL0L z9pqyDz!R2Y;3%A)9c~^Zp4mdxVR-f$j%SCfgQPQUv{egN2f2i+gIvPZK`tJU4YT{b zekTq@;q+{ag(V&kLehq-gIwId6o-z&@$7JQkW08aNNNPrF3W#H?6tlQ^5xlwOSn47 z#go;;?0!$6jRR3QJ=+udL3@J0Gz}~2q_Y-4sr=s2f28a zLl}N^gyY%a>L8bJ^B@La1>6@_Qq>*a1@Pa zuioMz3XV$S2!X>Vg5AG{tAkv<3N#LmqUDXOK2tdkj-u(=R1FF_P zTDUq$M(l>eQ8a({YW-~E$hC0uAeliPj*i0d>~M9ERL@3RwQzNiYm_?35AUDHM-lv~IKlOouH* z(R>BG$kVC`NA8N!szHUORe+$Oh=6OX>i1}pLMqSCwi08 z-Gtucj=_`RMxG}@3pxfA<>Jj2N6~x*Oclv5kp7BkvF?+0ars(wbgrHqe|DYs*!^I% zp`&Z3XJ?@!`oQkjPVY_MYrFPd;WyCHM(4duu?>!T|E?gK*|x?MwEJlSZ}fj|oA-|{ ztF~)SN`{{|IX1*;dFH`(Kj}qXDSM+ewJ{bt4qnp;H_>lfhzuF}KI3RUcADJkm=D9& zAJ=AWYKL=83^74aAWH2D^Tn{3iFWqZ!Tx%zBOS4)3eisI8>?vpN7q5K`F^kU{#|f1 z({$SlJs?e*ntCP5$$xj0y{cWRLo_lH-s&+~wSymAOI@{%QCtNFK*aR;DZ6u99NF^d zo&`tC3PSTU22wx7RZP~LYwg%raFiMXIYcXjX6+vtu645a#)_j8E^T=dj0B();rt9y z$Fqf_eP&*OK}09w4RS4q=LXr|cmLW-k!>CUqFjA~h3#aff#Zl71*4q>M=WA#+tT95 zXjYE|M=$rw4aU*#U551XETGI-0hHsSo+BX+BD)t9iA2WxPl#ni3Hq=L z73Ph2hcvwx+-qvJ5qL6O*)=wF){O?a&W~VhOi@X1kCJ;FbWqD;uEkNuvjfnP?V^gK z1GenxUTmGm##pobUc-t0b*H0o(--#I8`B+6>w0vmZ5-z($I*ctGdT>7W(<>Dz|rC; z9MA6kyMtKB`S1o0iH>NLZ#cqxaKq7b9j(R&&mIrUI2O;|*qnth;Mok>+)dYlXQK&j z*{Eo76pm;2{$1f{ZZvl$`I71l&AuzhrVM9kQF5=+GI8A|Qn8ph(>?M_mXXwZ|`%y+V>T10gZO5@(Dvs7` zM?Wg}JQ$A41&yAKUNGCN2xEsnzRY+F^mbe3z(#l@5|#z}eAV?zF<^VsAB z@$PgqgT#uXZCp_di-v=q%~;EEJ}S>XuBFZgIo4z53*EZKkv&@9$JlF~Zv;BpF^F!m zf26Cu0OoUuKehT1`lXn7K8u!!u`-*h2X74?Vl-{X5i?U7KLxWcAhX20S{&JW=$iHo6%8*&|}0akn!8% zD4d?%_qhW{IO-UZm0u*`2tj4kc0eUJIvUTb)gc*?vU*H?!|dCccUbkKX}K<&l7ew} zj_aDeFb$5}QB+p#^*W^adJ;-R_Seb$!QBfODbi&Fxo1?9!|ymk0cz+7ZRk9V$KeY@ zw&O4|I)YzsK8;WYFwUmz{BCg+j%T~IT2^g9C!8MqNl3$^C6>%rVlg@N`xj>7S5w=x82+G{gRxS89+UL)jV z{0IZA<45CtuQ8})vkX5xPk7wmZ;m5yHrl=9*d=h28_BeEWXn?^dObffzp4PrI2z@_ zHr<%LwmxV+WpMAy-FplNcDhRODi}7--gLKNA;yCTesNzdb_o2fDhdRMQ95;TgCnzK z(mhzU066OPY<%eKt}6QpGC&zdN9?+resnW-rcJ-cvS3_0A@xRiXa zofj;;;2RtfBtgT}lUh0o$FtpdH5?uC>Tl))D&}KHVh5UNa7w-b!)}=}x4s>ecy^sOQ-b1~#p$P2@+ByWpvR@MD+t zT6^W58qUOzWUgU<7>>w?0A=onBu+K}W`%%c>19VY#y< z;`EtGRH;6nK_L>uNy3rxlgi#pY9aO;L4*9;^`WdVvU`nZli`bQP;s;!#yEso0h zbdMM~GD}P#>D?e2!u@7cX?!a>q{oghu-x|0doi2Y`BRc>=Sw(F=M1Y(hVXob9MAgiV zj))s!U=-RU@W#k*5|V7Mkp+B>=G6nC$^(4L8*w+WAPBM7+)-2@8pv5t8k;c%6? zc6cobMQJl7I?CaGcM0*^3A18RBpj>8*am9an$yIA(!HhH;K<&-Ks4b0!RPP(qe&dRq%3m@yylK02&cu-fluu;yPq=`$$qEvY=Zx6E=dMH z&=K1jrBeqjj>75Lru7QY%(D?b4-C`v1z+I>7%$6~8Ho3HI9fe}T(5mVcdn#!DcaCA zx{nQMpp5c-Yk2m!VbZ2WYH<{fXZL;X23~R^{m2%Rs3Bfyzl!X}JC4X`Zs`cmBC@J* zoDFVIZuI0jq_TiL>lQjfokxKZ${HM*c9k$0Vz0TwQ6PzU@Y!Q$c~c&WVjk4An3#j3 zyByPd&3Haq99;{>h%vJrRRF#FbUH%vgFv(WU}OsBC5mlvWakS+ulJ2O<0%lKXOl4Q znlpMf`VkUer}>~~-*7~|%FV}iBKT&rxY%p_H%Ztg`wtShuubx<2Hc(K;o0~ORrj>=U?xG&>qM^CiU4lF%v zSV~cCui-A*cjNzwXDdBGx2`zCol>5qeJja%ux z*jde9gN`Vf!zj)_R!#)s{&HU}>M5Fbp-B`42np|!E^cuYjb~3*k(1sk(GhALyP)C- z4vs4Df4V$UifJpHLdfT{C{93@*b-rlVTTn)uN^qx6)krEX%^*F1lsleh)S6O*1zQ9*iA zi=${fdveXEtQt(3Y6nlVLZt*pBzP1$x-d;{_8JvvhO?|^kE8%N&&KSR@HaZz$gCkM znePRT$g@E)*I|nzqgj0)f{vc+APLDo5I=&D&vf7gs9cK*KG&-g9U-||91#q{0xog@ z*^d=Vc8%ePVB3seAm3Sv0!l@nH&T>JyCy*12nn498vP?`0U?w^xUiq8GGvF?j-0g< z8@nG4(`cOVY|h~j&-a9{VX|V$7>>XfT)Ob&WZXem34n%<%y*LR5rdA5(+DKt2th@u zs0(}9Yxt0itZ?Dq_Zn)U;Y@oCZ}vKy^9j$>LOuOl>F6S5)K>*P`@&6-h_1zv(OH4$ z<+jLVIquQQgKAuh$ov3;D|IVw|t** zbdS@Ls7A71*)9764;osc=V%dCp<2tVAIUZHBa^n;(2-S9CM3nck#Psd5iWm>F4MC~ zccebne1`)yGxxnV*Zj!Dv&nemt4sv4S`-KIxCqACNjXG5%htmWL#$heEsnzRY?tbS zG{&lhYOhILkuvS~!HIq%1Yl^=$_8Jji$U4u$1sQnMH#Kb1z*CC@EQ4>kX43Cqi3r}RHY-a z7^*>SwmDVrxX>umHo11eo!mFV#oI-;O)vZ1-yH`>9nTIxN4Bry;K&rA0?|MrBV|YK zRwCUIqtrcdm|u4~QjD_UM^rk%%*s6#%SMdV++$is;7=+dQ}H#5B>Oyn*U|-0kiBL? zJ`P0Tc(yzD3y#R#m#fwmn*<}(q**OB?f5!=L_$_eN4Prhz?R)Ye(psU`|9z2(r$L5 zM|xCp$dP1HSY0F6T%_uv5ZZ`qhjAb>9WxF@9nZ$HM?WGvO%U>tK7@2KxM{R`=SO7k z-RX#+u0^A1ex)R=YWGv1L$Ih=KMD{)M}541a$QW1k3mNr&wjmJ^Sr`1IO=#dbc6$Y zcNZ>nbR3>3JCL{5(NV3j5sM+1h6}q`6I2M`#w6R%^dlWnZmXBq#bj^M2`Eu)%a4qN zbx{a9viwc~6a*qOgW^Ec`$lMPfh)`t?!=D>+M7QkcNb~$*htlH`4MEH2!FyjwW2t) z2}8PEqr!%&zasTgy$FVXZ}+=jAP$Z?p8a}$WR(;N&!VY=(gNB5*kY>O7mu* z8sdXI!BKf@aCEOcAQJ49uGgjrh(^anD3a|##uG{QPTBN!YBI*jcqLNvgriQ+4#1C| zcs8z1W#|ZJd?fqn=wYe=UJ1vE)}C;=A154PB+?8d{gjRaGmTIQd>W28Aj0Q7n=m}x zc6%IoMUie2f{r|oCk{lm9&sQF$FnWxOehLMM}_hOL1f!J4vspW{dx}RPT4p(>Uj3+ zab#M09LnzNAcvE*RD_KQU^2vs2D`dMKP8uAl55nu-m=E%EI3h3kls)6KScdrtHmZp zPS8^~pQW~y3dGXhveA#8>L5>&iRtZUtQ?5QVsuQt0g>lNO45?FP6vSUV`U>LJJNG& zDD)zuv}k{Vh@J@9b=yJ|j%QnrM<6=tcs4z|adx0Y=EWY!fWpA>&MnU#_Btmbts14| zlsX$7QBOw>rf1fnPpX@j)6tn0S%>Yah2z<_FB04#G&WD@7f3N6GJ+`(;S3@9uvTY~ zkx93XFGc*kS|iaBiNegSN*IS9F=~z4OZTy<_MXbad{(T2ocrAWp`jzIa7kCm1`qh)BvX>n=k?PQF6~k}zZQy@Vt7T9ytiM8=$TS%Qd2 zEDlUtOy!8;7&RWT=2jYR(NJc6%ZG$fkULxUFA!1XjY(7?8W}HA!6$}`+f`3)AqvN{ zP09$+7<h!2^wrNJH{NvVq9b zNtu9^84#hk`Z`EDv?U74f7tym*R%1$g@eeraapwhIO=$I0EnXTY@bY)s3`_zn+%OZ zN6~mT=IVX-C!W2~O0s+nhoscodBm4_HhDty#-TbPs~>PkEJzX#IZPaqJ{Cj-8qeqzP&N~Mt9u5@ChlnZ#X!r^FK8p8Y+Ceh zr9edexX4_)WE~~Srjg=7@u;ia^sc3AiyqxjcDOo7>hlwJ@}Ceq+j=7=kYYd-j%Rys zTp=k2jygU2_4<+56BZn?`&C0{&dot`joL~Rb89YEZ8iTUi&eXyShx*;My}E0guWNP z`w8JT1-}#+l4PH@R^uM| z)T)K!+5J4oWQ*Y4G*cIzjepg0J>JsT?*8mi)da=6K}YA~q-$#B*|@st5Lz`h4A{Oa zLrElwv})n%AemZO@S}f1?EY|dkh9H7OPGp*qj0_v?`Rx{jym7S>$O_%{1^vE;d~=~ z9pvj*&FU87?0$>m27<_hd>G2Mo(_R<6pm+mN^hK13&*p)aeo{fh2z=og$;uvA8ir` zqHub4xH`x>Ej-Suh2z=b>L6$99j!%+VL@88Ng#;A@$7JQkj!OC>y`h6u(F@(AT=^` zpEh&hl6^>f9-D$WFv95`gQS(uEhCE7&y<9f7bNG2ki=CoqAoRbpBYr@9xbwfkEiIm zXBF!v!j~W-?bA>vh^R<20N;SfyTzuQQKJ30)f^(mUQk1uLEuf9=XBJ@gXD~ozL}oX z#6`TLWr67R_L}E|#epcCKijA#gM|K4)p%YmQ-wny8rGj~sT*sA80tvqX)Fw`i5RVAJ3#m+LhA$Xiqth+fZ+tiN`k zRWtbz2S?%bY@0w3Xw|~`M#9xWlAf5>EB^^0*Q|OY4juJ%kgw;E#_?8TF!PSfA}! zhB$e)VcPxFC)(cQwb*MrbLooC#a<)zxT%t)a}I@%<{hTzD>a8XVZYgHzRiWE7&tPB z<3MEV5eK4hdUm)vNCxX^xymO7Wp_NA(eDg=E%T58l+BtN(G{3!>)^6JNm@;@^8Kyd z&-`h_yR24b3ft5RWdBL)L-!yeX&JEBcdR52&Je`EF>n-(XD?pkBveJf5jx;~)dr^i zO4&2i(G-)`W1i_wC96vf(Gjx&Q%Os?38nYUg|S=|=!o_srGJMsHpVY;)+iSpk}tA8 zSEb0}UFdbs7&wZ?vl(t(5FQ6d(e&)ar_RU0kx_meh&rApev%}Rv)>$TH)#z_V%K>jvG%#x`S?`6~P{`aqla{qj?Id{F{lu!Rxg;9f%Ip*i zbYKQz9#&fejqThp4|VHCV+%JAatT)lx%BfOU(d5GjFRXigrp5O4{`}t2f2i+gIp{x zFAyDt)3d#rSV)So*P{8e$tg_~l>fxQQRf?ZJA?kR|mP6?>P}t2s#Q^2U%mn zap))<&ki>aatT)lNmJs?t^@70a6Eer=g$sT2T8N*Xmn(~?Bh^&xH?D%CWTwIaQ^IY zb&yNAI!K?o6=<)8-YCZ2Z4n*N%kbNEG>n+G|b&$0$ejGXq=Nqw{e4!}F z?hmJDhpU4uLp0Nx1z9!kL>q>V!qq`8UM&*`N8$8rFENONqi{UiC-lX^Q8=C*t`2hX z%Cs=67OoC*vGf3;D26uTRf%yR3dgh0aK4dnb&yNAd5}xEI>;ql9VBxW6DP`lLik3) z)j=*-IN!(>F4r&IJjliB@e*mrpzLsZc0UjD^*%N$cnP#>(frwr*bTw90p1t<-AOq~RXugrvM|Fpx>~M9EYq&bdwVwz1ddd!0 z2kAX#5}ypgv%O(foV^x~XNQ{yxrVEQT*K8tQg9zl8wpnjNw?N;I0~m{hpU5Jt;22{ zDH5&@at&7pxrVEQT*K8tuHot+>9-$)LwXy+}HKPNH_O!pZIrV)KJg^yBk&e;TLfFaQ0&8EynnxRJU^jr1&Toym6< zyml!_-a+SL5v)NW#pH%?{@o#* ze|HGy-yOpFcZYC&?uKyw-633`yCIx^cL?X-9q!8IFuW?d^Y5?E|I#;T)&Cy?*nbQh zO!nV0zuSMmbS?jt>u>ho4@H-IxBujq$jJBwtf=E#t&RL{|GkaS7Dw;)-`8>UZvTB9 zNALFES8?=i|AC^n7<|Kz-tE6{z)?7!{cit#!>Wbz*}dC;|BCMZTl^;5e}9>-?_~Q4 zMp5Lq#{Ujtfwab6$M^W(Z?U{zy+^VCAb`e?|8D>N6DHbOcwatjbcy%)-#s(n>m{$F>& z&mTYk{GHQ3zij`_8$)nM&;LA@Me)CR+27-T{}aSEv;<%#;2ZYees`?3dV80{K3vzy z7<(@uKaT5huBXYaWj_|1Y^u9VBXf-TB0qb4(6#uSt@F&x6s?ioVcYM2r=oqvXff9K z*h_xr_@Kn-+;hW|7NYn3PZ(TA=q-HN;>gxRmxa)hhtB>Ru5Dc&hqsP8Rwm~9B=tN` zx4fp_>$;}H=t`8bT-PyLM}8)?DZhL>jE=}N-F_!tTeruwmZJTldU9;EX+keBg zZ`0%Sg3V*wAIIW7WS4CpZExkhb~z8%UZY#cL={Iy8OS@Pi^f>K*G{JNS?8{Vqh-!R zU|Jl79MA6UKj>&&9-B96I<^Io?H%ozY~egQ(-Cy$EJk!R&WrU@hK{ZUaqqI9Gv~OM zocv5jV{UZX;;75nXVs*Cc)LHX+B|zj>07HN(yqIoH8UxKHgeAAIi9|1`#7}_9mjcY zi6OQSb@rd=Xnb6oxv2!vG5HK4B-3R$(OpDG8U6Bhk^aUEAak9m{ptj1}Q% zpRU|^xrHbk&%Q+;#7B_*lJ>?FB>S(!GijG?>F8)W4QGWP!LiDZp`%?4=yDvLBNR}$ zm2kwvuCy8rj{5rkylT^7s7q3$&enTNinLlSoq0}}VqQe(XqlnQ#Ua|K=`s=pqH`f! zmeipZq5^Tc2mgK3?7n=+U4FsUU%t47$d*SSrB&O{1D)Kq;IT13_wvb_X!ae49FxkH zk%Go{><3ITA5M>JW?|0JakPNKwQxXiG(+{78MF{}d3Kp+V@~Fq4r#AlUg7?=-M?HD zo2@_uUt8vd$~c2)MoMnR+koggjx`TlY9Z=)wji33t?ll=cCX$BA}Jrv`L+97egs22 zcC)4C$AntDT$LZqJME1stDvxQ%qVLi>h$biKpEWS7hL`2i(80{V6;jxDEm#Gy_(^f z=xE!$cf(t|U!IuUS|CiXY?al^~_a=+@O2Y5xIE3wk2EJEsl)w6dYwbauX&~ zHU?9EE)B^f(|+6 zkt;2Z>{+@f29Cn<>~M3Aho$4$0XSqho*iz^@nHN)TP?<3bM-Y2L>^@LO5RF$W z`=9je8_yn>5yLRUzreGna~i8h>;G@>+_EG|ZuDHwT19L?al-HJ3(yL*0G_5uj`%>0 z4tpeRU*B(LfWa+_RV)@;iP2>8FsmcN(;WeW{kX%3U#%UpH;n8yQaoU`*#@1WQ&BZP zDDEI$#22$2srd9=i@Yv5wUvYt&wd>?-*qBQLhNC4Uxd@%&a+druE&gHpude2rNiv; zoa1VZtcNM!B1eSkD-$F~SkHG&8@(fpi-izUy_$F?Ji3-{XCKU+=?ul1C$L)#{m7#M zv#T7Des;`c=VBoZ*R^gnP#P&R3DMW8lD+Rw zf?$Z4ty(VVUmKrx#rQWK!2tqDU9vYqShf?Ph=DyNlN@G~N%07ztMU;kGVJRVVI>~!=xfz**Mekw zL|u204H^A47J}X0IJ%HeWkOPjjjR(Bm7IK7PYQOF?D3pqBwLa)8@_Y3JmMLbB~{?jHSL7MT(Y-a@$Pyr@d($dGBonYmM8Ftj9)-VVu0ArPSLv@-FCks z&E{ppqZ!v^?Q(=xS?pXa3p|WyPv_~G{_v7%jZ^^1{2jSxG zuOY{C-2KGY>(Gfvkx59Wh;@k(c4D==TT$TANYNSh8Y#0C?O%DcK2d|@<~l+Gh%Tb6 z8d{io09_m@GNf^es0nxyN3S=19PD-?zAi^w5#;hn-9>Y*ZjyabWni;5h_J)3YYjZw zF2uRsnpH#bFE!#BDY8d9MaUv6Y$Ry+?@NgJzf1N_i!94@+RVw793;v2!vtP>4T6mBuVD5WwFvR-WwtItsy*~NAS6P6T9lRV4bTB+ zBSmkReau*mUH9)32@2`#L9Bb9csF`X4kBG37E~wuN`)F6H$k$$4B;paf8_;(xLYnqO(K%*Q1aX>< zl&0N|*Bc%=I2Sha>tY9hY;6NS2qf~VTmIX0v$Me-U&WfKA&y_eW@XhD6xrG-B9(>m zw^bu2@DeqY zu4~900S4Qf zSEA9U zdaM|G&(q3Nv3w>7iJIMNMmSJ(*tgeBB-!Bl{=}53H+>w_LLS-Ib|E=*lcSB#8yXZj zQt65%FyRs5>+|Ro5x%|*KcR@n5dYSbB1LbQePPw&QW!;Ok$E#sB_8>1*InMMTHuK^ zUj1XdBOHZo>$@MYn$4+TuR#zQHeDPkvTd&S3y)aZ=j4v%@#32vW*a}2WxXLJ6$ZYF zg-00nq%3ta?KO%r*#6zB#eF30Q$K}A)RzGkdKoFQZLar45tz-L%&aOlB}$e`m9z=kd>cM`x;!@3@Cax~i6Cx$0l z#CAWP(evas^)66EUODLgt0uGhLyE3)$)4C~)7C2xghwW2QaRHC&vfg^qXDyjKr*ivJ+5bNYf~i zTMY(!WOSe8y_^5=AQ0=Cwa5`Z>Rpadg609s8riXk9gnE%rz)n)5w(BwTP2J6ydtRW z{)MPo$7~{4I2X3I_|U%F3q|Mb6c)+GkN1;`p@?ll@WH$zED`*IzWZ?_KwLdJ%F&3~ z$4(e;_EJ((y?7MnH^Za#ru!-R^w)(V!Vu0;_8O%>M6{hE;%y;*gu)?H;`>&V@nfDr zc_D;6_=-fvZ3|K+_ry*$x?#JoQsEJk8{(>ASg#oB=OnKhW!U9?8Rub~YuM9v?258bUHbjtD=Q z6%LP%`M~hjtpktTpw|0k)u=nijx`00ToPmR>XP}S>NeK>k9b8*RL3K-bBK2RRC08Z87Yg@c|^>O7a{#XOZ>fewKpve|{e zxN2sL>9QQFX3S_5JuqWc>uE5x&1Bb6*!6ooREuIf(f7g#bj{l|?Yf#h0e2VT-?PWq za46TqtUv93B1koL7kTuC*|Xxop6@5JfW_t+KN^W{5iOR;SFupE6FN1I3~yM)iEE$; zG_o&CL`!O~I*gGbV}|iap@iql^$+GEgc+l;}LeCy{-sJs@QZ6dX3mTwzeZA zxpmG7s{9s@4zi?0kRwI59!}B8GdoDrgeUIW+M<o zYkP^OsL;2X)sZ6m_D&IBQaR}QMII}88=&9l#uaf2bQf;vJS#k6(cCA8BH}S59-Jc7 zF5XwYH58o$bE@eQDY8d9MK}+{4-FJHDBT)}LtF5?m2jZ1P_wFA!}A|&1r zJKlJNql7!uSM4O4WcV-1o~LGZM;_Vo=q9=oZ6#!j++Sn2(o^G!WFXopC=@~aogy{S zG(-W9*#0!E`Kn>%xS=D-R{E`c*+|iV*%U~M1`madLsy4-?aq)+(Py8$OP14Qo4-{AlTqJTluvRRzM zibv|tX!Zn>O`L%2lkS#=c<#1*a+rSIE|}j*r!|M;L(WLszcK*5QY3m zvdPlIiX!L`R@Ux)!0}z;_~h4IoDD^_a*bdzRi$!6UQ7MNq*b zls%Po-cy4~NadejMQGv1BlOaJ_Y)W)!C&qs%U_)l-OFC6kn!eWStG>Xt0@q8WVJU= zk$T=j-H3XOQHZvPgbi;L(XMjWwB+V7WSt_}WLx+9RR?IMS3yWz=5f{B7Sm0H6pDeX z^ReFaL8TA#CoDgusNanuI%FK5DjqE_x1_-%Qe#A)Y_H7#HlkB+Es6xVZxq?1by*HM z8ZjFylv+Pyyn;7aBM#w2I((J1_OweoK8Z(EPGX`pz$flJqjq=a5s@63!Nwz;E>dUi zY1Oyen1=eIN;UzMVAaBRcyHBv9GbJaW)(%WrruXgCE-@yDa#+R>OIF8xP%RzBE0^q z)jCAU9x(gkeOfn!#HJi_G+=fD9u1g{XOG`}xN4=$6rbC4=L5u(5^-t7xNw`Y?0(SH z8!4!)!&SoRwB1kr5i$0rhuH??m9g)%Izf)cKFE*fk=aiowCpwd?{{MAX0Z|dQBSmC z1cw0Kctj=I&0-@BORAw=UA%RoC!I&C$?CBYY5^|#qV?p+BePeHA{a~Eh!yNmC_)_@ z$s2vl4{q^|B5E*h6cMPUYtMDR%KG^}ebqo9GnfTlh(k>jM~c#6w$-^64oI(+ss}W7 zd4rd#L`GY-msIQAc|=G`Z`6-v^3ZD9y(7{fc(}bLf*32Vzg^54Zg^LE8F^&S()*%F z8Kx&U(rbQ*W+}hc*5QE&`1$U5Moxk4?lDZO;k+vsSG4RP$DLiN}I4~PhI)W`f_(cE-D!GxQAglOPbyPeIxAe`jU8p27hmziG3(M74% zSbxMfsE?}8<2TV2yjVBU(1lD5@w^CM>c%6m=dNj0d2F>RM8bD+O;fl0A)vLa2)t+% zCu2E!kS;JHsqhGk1~0oYo&reZ#H~VR$dr_0N62lc_Bn~8S#4aY5tc6Xy+&3AC%%09 zVki(f87o;RpRAvk-y%bh8>*pc>39+Vv9-m<8hCV%Xi?>Wi`c#nctpgC%!pBhs>dE} za-=#o8m7nT9+Ou(iloXT5XcLf!6WQ!Y6=U*;886a3q0yI?L~_)rH0^6y&B634j~3c z5gehKu5FrPOublRT^uCa!+UxkiauV8SPV`CRUXk!MQ@&MQ2+!#z?BMhySG)7i5Pdk z3c;?%o1p@?eZX~sP2&_8RXN7QR}NVAEgn> z5fayfYVLM5e~I3rJKR@IkqOJ1K#?+#@2h6aXcQ$_H3Mho5zd*Y*K2+V`S8kHY?@i! zd8CT>phd`f>YVuYxAb*jm(M+-B^_g)7WaikZ`t)eYe_c|w@E)8)Qmbs8_N`i4^>0I zQ$!a^qzJo(J>3um{X?ZOrDDEnO#ARJ3q{O`S;pF9j~bM3RVX4-M@@`Dx#Xy4gQ&bI zEa?=Hj*b)&xIow&->LN?pN4L8iWG+k)(AB!$Jm|Gnc+NAPOmeC?*PZl4@J`sm_1Y< zs(X!HHi}U+8btbooe*zO)&+a&*$;rgAY8SATsg@ zP09q1w&bPucp?bqJW>G5On5MxR33R>Jt_Qxwa8Z)@pXOp2IX6N>ik`OH?6e()hA%Y4;IHg$D=9WI_3&u8aiip^| zJ*2yk61eGpVix2rx)xEJPpHqvp!2>>Rt?*QDlR=aQe>8o-Y=4^4v}CVVRb8`qL2A$ zPIl+fj71lBKSr6?yb^^b@)Rq^6{PH5HkFGMeEPlW6DWGE|51JyiptEofJf}Lo=O_= z2zSmS6VkNwL7{5fs%^^nVI_NB1S=MiY$B>IIgFb(Ys74WP7%Pa+NwqGly*wrmh;T(vjM2H-T2t5L)s#X5i5>~E5d)VN#~ zYlNU4brbcEK}b>%So^lu(5(2dO#+Z3>ijWKbaAApeV=jX zsbX}>X+GftK>0S0C_Tn{D0d?=O3G0s63!#wh%$)!DLmplrMJpDukbR867c8^vvGhz zHjA(w^_teV^Ju9e-?1RxUDGP*&~uP9s!s`(tv>7xC_1#YzH_sCxU9tUVki@~S6? zy=FN|y7A}+QHM+)I=Wbjz6PQksGHP~H5R!Q)L|}}f+Kdr)f1j%*Eiw~O_e3}p zF)or)Rij8%C(Mek_rj)70Yxp_i4>VZ?G(}86|51(MzE@kB24Z(kHRF2qSr`6_$(0E zNgkO-M5jnIVl1Yq@RtT!zU?)$d>TawNnbc{#uy1&=j6dsjHI!%t? zktC;28pOpRckK2N@hxH_g(YFt?DMj=Vjy*@SXv&ORfHX*(4_5L2RoY~o>8*NpHYL^ zD54$?|B;$@TQy}M8R%A?h0q~z^hLcddY_=|rJhEM+_mQcO-~G0#A}9$(17;`S zQ98`_D!w$UX4qkJ^bpeHw;1b)wPNdeZO!{$>s4gZB2?Z{|J-&a)+fFZE!4i(sHO=u zTKL1LE8n+;1oHO-WPWw;3A`v$;H(k&6^d^0Bm8E@H#v_e#UX&*c|;od zwCW^Lgsb$H6?IR{DI%)FtO_H6NCGybP2*C3$X$z^RFnrB5)(`#J1YGf_rYH3@gu@t zv}rdEsxlQ%pqfjOM@waXnDat8|B_U;Td!VxmA z^omDV3N=v{DH(-GX6JfpYa@0FBiySc^Lm%_=U5bc1G^dc;5z*j;u5PhG5%!kHkC;C|P_f)P zQe@v=&x4|m$83u)iJ&AD4R-d&^T_%Z^6==b4-zfH42%$mRD{Drw_njBW%HFUBrQTF z)@?F&KVnYy$+d{`4rU><`!!FhrYwSF+fFqeY4^u`zxEpOmbRbSYlEE)p5J!AroI_M z9;)^sBdJOjKofciRs#r5K6h(5p-54~*E>Z~)6V$HmJ$CuC?a)Zu9b2;V0gi!N)i4W zX_HQorbdjr-+W%9D1l@f_KBnvcw`(l9!ZW=yJCur)-P(v+^+kI9Nl$4^GJLu-A>iA z$~5HDvT8bB21l?rjw}4u(jZZe(qXpS8Ew_zk!n}Gn_fI3;9@4_JCDd&1Z#xS6by{^ zEtxJwSx&97cfGS-~PCYsDXuxc(8nI3@OtD5(vDafGwb8)uLagYf`#E7? z@(dc0G3rRD=Q9!*MnY_)NiH!q(5cmfbc$vxuL^QhPF*oV#Ul&~Sq1v}3Xg6SVO^;4 zr(R5qg@+QuGC87^4Fk?Yx0umL!oY1HT+-HB_kv)%j_W~)%WUG;7s_0I8v z%3MmRZ@n7(h}2Bzgn~HYd~UG`Oqq$Ii{q+6y#HjtBbvXQo*W3tUcXbMRilIUhLBeq zPRy0>l6{Z*5r84u)7BUXq+*jOpbHNDgFa!CSS?$oEn-}?cRQQ12X|rE{oI#A&qnt< zMNzV84JN=w(NQH~rN>Vb(*-~X2LV^glK=-N5a?qrgKixu%7)oKk)ZIP?KQren`p&8 zqQmoV@+jtxR3wOJ|7xgAq@MdzFKs;1N1W!=c|>xnI>3=fwy*WbN|C%&bA=0LGpNDV zwvF|3455@KSZp|Y%#1phhJj!|4rQGTUseq}i-w`FYMP)suA0>Y7>_>OKEfPm>(O~c zrO4{$hx8ip55tHy(zo-7N|3H;87TqcVUW~yS*Z+RCSA!L6&}$wuF=eW)u@-KfuOKz zu2LIC33!wavptcPhercuCs;Mx*Lir94zs;vB@d4V%>H;e@(5!Z9(nnE9*PD#JHe`@ z!)z~B&$DXjFxzTi#iA6^nl_@T(36ECi+beYQ98_aFQf4Y50cJI4{ny+5k*9%kJ}*T zZq<^B=~k@@cyK?glaZLJQZ?oX5H2QD#`KITBSdScWWL4|Px|b)G^^&t4|ym`huIc^ zFKe43TH`%Vc~&i*oo#&!wrYwWsn5e)-5QDTssIgVBv>4Ff1hEes2^3zYD+11qk~1K z9g$8qCzjG70`QFosy?LQuV#dUPdoNOe!P8TdECe&rn`6vlz7C&iX^6j~phCpI$g@AxZ zhF6JrWVTr2QG(r{&d&B}bZL0x8IL>^*)GaMQM%ZO7pyfNNw3j&Lh{4db{}MG$=&qlS^pHj|6qELx^p<3!LRR-I@(l3r71Zex6* zh<*{X>)uyw=sUv7_Ut+oVgGOXoHb5k>}m8)5%ou*TMRj2 zW||R5oyD;G?^UeyL9wBoA{AgWI>%OxejR9NQU*mde7~J@?ATGhr0`pP)f9Lb36gBu zvfUSXtIw_g5*hjSUTMAfqHif`7ofah9>bC<$@QD3UpMhk6p!&WsRosy`~CM%T}>!3{0S6N>7ffW)jjU z`gnx&0+Bov4VeA$Jn}Y-G(57I=^`k{?zjFIqey!VJ2q$$^{(423ijHF*&t}dY^)7V z0xWma++*y?S`7^jD&|l7ki{93J}2Bhyil7G>(w@&|6YgDUa(|C96@X5`kNr*jG)%&^Zg@7D#)Yd!^ zMd>ixBE7~V@Cd)z54C3W80B)*SU0hH-)ns?d#ODp6-|43y}EeoOv`9;M862#83DZ1 zJ;J0IT^#VpGah>d8X9|bWGQ*|ai_T1XfLfnyq{!C8DUxLO#z#puU(D8)6}eM{r*T^~{+f`H zZl=P1X0p>kFRPZN;6}XLoo93e=0Or*$GRqsR5$J>x&A0(2Y6TEG) z8DWR+rw>*H^FxaBwra#*ZmULsjma?LH9zznDK61_j%i>~Sw#I5$yR@D4Jkw(nat|4 z6g*1T2MM4y9_HbZ?dv=gnVjXJXu#}`-~AR1FVd7_uf1V5&F5hjD`%vT+pH;Ys3w4a z$D=a)r^ndH!xPkRl7Lksh(0}{MGFnx!nP{HBSOtZI|Mwk-mOGDN@r(#H*wo*3>Ga@ zJq@N9R?4hPj~;6-g=toCnnc1)({fabjq2k=B8>#Fb~n*Bojm5vda`RsH4UqV-CNeH z{>mWPeZqR<(TDH;eu8lxin3ug4%1zZ7*9>Nn435pfq>+;=4r0PPru_4kyw*-K1NtM zw9|TBIq`y%vG^0SA?c$cRcD(9l3*3+{#O=u+tNOj1TbLt{tnfo%h|(;7-f567^%AKW7n|#YV79<6_IVmwCsq56&FW z%dq<`8eXo_hfE_R@a(NNoHF&KB*wJgtl6wBY_Gd;c-Sq!rWtg89szS}m;=v|LPimd z20GZLJgXR-#IwhW@fMi0YZAmEdmWF6N`XgSjFpEXTh%-irNeBiT@;Iw$Wb~w`>hWW zz#x}x1%wY~Ix*kdV>;MAp1UpxiN9<3BqlREg*2YqMBw=_2K$7_}9)OU{u^B6U zDRnFBRez<}{SMBeDF;RA?Cf-XkW5ZZCr9Zp+v<}Fr*cSkwshyIu!Fq_(d z@vK970qV!~nhZ9i#Z`@>2mSb1*3J}4t{9opzJ*<_PXR;IyD zK8+Exo1>O3>j{rILbC?2bg%l;kL=Rx6niaQA7pE?X&lSJqjZ>Uoe70YIe3%~v%O>` z&0b5_2Z^2E_E{bt8G`1aD4m@>o(K8ySqQJa%(H6gFnjESOt5O{FxzV{)5wwal8T@l z7MoR5CZZ@EX4@$ZiFjl=fjn}QE;eHGND{4Dx_EZFKFD5snMSfLJC{d}()B@7Pg%HA zf2Hss)Ad1m|4Sk{N{87#7hg=uAxG&j+a_Bik|PTfr&+bJ5Ax%^qp=S%0Y&LBdpr*^ z0guwz*=IV;KGVfUtOGa?LXLfq2_!omW~b|e!A(9OP;fIP>r*T^}T4e+zf&uM~2Wt`Cxt`ssL-4zttsL9X5@rNzr3 z+1c#uHC-Phg}mAJTDm^Sb?k%u@Q4;|is@D@9cFtkX&O9A*9W<#I}dWTbHIvxr_dtl z`XE z?1TJx%ud$_xsH9133!wav(xoKu0D|_ji&VjAo5U@E;eH4TomL^p=s0gLH2`<(#TP| zK1hb76bY)oQpk}XvzTYq(#5mW^+B%Vd5|Bk`_uJ7t~S%5Y_=SGZLqT+oVCY14UbjhclGumn5AlC{tO!we;AG~ko_wyh%OOVs98tdi*=B}=fkMV4=8^>*tZ9bg_|ieUQv^Ya*Oy)lBm9Q1ph`oHO;@ z+_BUY&#j+Rz_}BGXvgeXQ$O45aun8e>A1kkch0ruuv$*5u!&4m@^H#$Ta_0F#4)X} z2C%~JPuB;@LB!eQC|w^U=Z&S~Q93)@4-ZeX`_uJ7u6|-%9v-E`Y@hj_hDV0@1p`vp z+3ETqIk3KPr~b;pqjZ>kro-%XeUNLqK1e?aHPP-*huJPFI?2icB@OSNi4Y~;hU5S%dC_@jR^Xpt>lA0!jS)A1-9 zW^dzpkO?F^TRfXHEz`+Sws`jT%4TP8>G~kIbbXLa_|GQU>G~i^Yoy~*w%Ev)t`D-G z7^lTcVITQ{eR(KKhuP`+AUCfoNwaF{`XD(EP0VRODfZf&4zttsL2l{#AUSH(gouB0 z$Wb~wJ6#{-maY$ygTS)MQMx|JE!}yL+ma5m)Ad1a>G~kIbbXLpx<1G)T_5D;h1deh z6q+_&ALN#<4{}S_2g%Xw*)*+}tLBmHbn)zTeUMwa^B}i$eUO{?U8Irhbmu{C>G~kI zbbXLpx<1G)-Fc8(x<1Iwd*$-%{&caCbbXLpy7M5nbbXLpx;{wGmd|F@raKREOVG~kIBVFA{x<1G)T_5C@ zt`BlccOK-Ht`Blc*9Wx10V^+9gw&V$_2^+7VoC!2Sat`BlccOE2zJJPLMIy*aE zALN#<50W`8+2knQd5~MWKFIA#huP`QgWS^fL2l{JgWRrcn7ya#gWS{gLGJ1LAoq0V zLGJ1LAoo``%-+-WLGJ0!gWS{gK{6dRnZ>rJ>x10W^+E3G`XKjoeUSTx100 zoCo>kgMR+}%dda_-CzFrZ~yu~|MTykzyIaeKmG=EXbkGUu3uiSd425@|Gw6FDgW{o zDTV3vWm@(bV|6*U*O%AC$NQJZ>o=g~?Uw)R*MIxvuaC!<|MG|b^UGiV@cgg8{OM2s z`qw|aUH0W)Ueo)V|Nh^3L;)~GIKO5VX7XvZygzJ|K83c_$J-yOR{n7@$NJez4NqR3 zt5>nC)2j@|)t~4t6VF;1jH}n0i@Oj&UCbh%pV!XepZjKWap!AVF4K>%CnLG%s}@;D zin7IEnAl#wUiqD&uHf;=rW+oQ!JdCy+q^vc0SD)FAtoNFS)LmFUF7Ik zk*rpO$M|&g^L8yJM+-wH7yA@Bn!u-8WF6%wTfgPwk*%ii@yHf8M-uLPO?b3DQ7G;0 zf=9D=L4ij;m)r0Nap`z;zK+X!@22N6zpmG^x*Sn3xR^{LM+-+U)CTk*M}}8M4 zKdyb@LwZSyyDd;K`+Q;hHC@SB8rLz+^WJ%Mtdms? zYp)#(k|u^m9@#e6`^_4epA6U6Ykp3!09(^^4XZXt_FUkgUW{a4%-OcyJMP2w=g1DH zh;vo2lFFuUQAioMI$_L1JOhb-rOdi4Zygv~q!y+#S+ zY*~8oh>cp?nIc8$Fxz*LzGYc8AmX|EG0R2w&+gBn`)@o#_dAAHIf6qLLxo4ve!xaw zHCj9_>t8Bzw9mEpBk*XPYob+Ko}9~5*P+PK`tq4I$dRAzVykwuYA>ekS#EHC;+nrW z@4+eJzNhtgLD7MORF4OY6gBK91n}P(pk($fLo|uB(P27*_4IxGC^m-G5P~XdRP6 zdrZj7cmI5GB!|@uzMdSwbiS$}M~Vi_7DfAW@=&qx2%Z>5K+#RI-@Kz^o_6EH{9N&s z_!E;O&Iq9`xA6cuVm8-WldX{=LmKfUha3%4VYai+P$H#=(W>#Btqeu)hLp? zq`Ow{=%gsHy+n>)9NIW{gq%*cX5)b?0)GJ(>q{G}uSeC8pJ@Wgl_yoSkHgWFMSq7VIPJp$0&Oq5B11j*{*Ap;7el zyMLT((&Wg8ixi8EE!$WIk8Y8O3AxecGam8z?7NA*#+-tAbIeAiyrOq>qSY#}L^(=_ z*{(zLteUMy9*S&J<)J7YW;+_E;gR|1A}9xDr<-f?FdyA`)U=2xf}%yvm+RxNStB?5 zh=_q#1y0WswG9ZGrsZr@Vz+LM5JaF3ebgdmr3Z@Ei_${ij%+Moc7+gfjo`=7EuG|+d#wg-j-6@(T zsowf=jj{Owv79uxa(LjN%z-zS>E2*H?{2A}nbP#XG{nD-a!dG+;K8y`CJIYl0))e@-Tik|U2i z=q~ctP}@e zqXl39_$Mj7llZaA5oc< zKL-~WQOSsrza5*B0(u!KGJ(kJxy;JmJYxcdi9IUYA^xzS8 z0DSUQTT!&8W3>A@srP-a*|VG?v={*eBUHPeaIh&A5OUc4e9J%)3$ef_-As~=l%VCh z9L?tr2-Q!K>>c8(SrK^T0;9|7?%$MQF@e{r@kMNHS+#*jcb}F#C*PrcODs10e!?Hl zBX$?M*C<-)(%Y+uMvB_1ma7Uy2hSucU;pfJE>wSTpY{?>IcSmB5j8E@G!$1uoQViK z>#{qKR5wC`%_({jMXlo}B1Hpce|#ju(4q6_0wJf)BSnw*sMm&7LwQCynhp$w#!)sQ zs`gx+N9=Y*CXGj^xbv!`ULuc7W_4LvHOw>RbnBlzFu0y5Dql5#AnrA!!qK2;+VhZw zQU6$bO{%r;enx{HwvB~H(}jl8#gQTtVZC1^8$5bh60B$uHi*&9CcIH3JQCCN*G1E^ z*JjH?keNI7oxgU;#<1Qk^21)kdTZZ3Qe@btI~Iz_6GVh0HcNWfu3BnkizB35593+o z5hsJ2eK$P`+Y;mtm`#4tb~ii%!CU!Mq{#MlqbPx78x(dPQBr^*qu2c4+^D+Cu3C<} z4TPlpxeQ!=rUQu{rfJ^2lUX?>9Nxo`)BR3bQE%F=+!K z->i`sJtoCClMd6(DF2dmJOj%vN6O+@mj;S_U+aBQgky}Rwe9ja4!j|Z zWqr(#Dkx2EbQjDC_i+o4WNz60hDQ`U5yN(hu-*vsmpdu=y}+TWcq2u&Ji4s$=y-aW zRoQETlzJC=N50#2m-omh=AG#ryrboK9edA_)u>ytCl*(v+w>H+rhGL@QAO+s_Np%BYU*oZ#*J% z>`ajy5pOq&(ET@x-aJThF)bY=-Or)6JH~*o+5{ZfJTB?}7qOBzIWp{P6n*^e_o#>Q z=p^M$uGqHVu?a6N{_?N=!_1%x6#lmd6L`f7(nc5N`<;Wgg zz7)UsT1ccRpU1Ht(m%#BRWup}y32*GwAV$lIfQ66|A*aAl80D}$q^J$!R31mir6$o zY$8R5#*Lx`a%A7$c{GEGhXq_72Z*?%D)ccw3+9FKMBfX0@xE%51zt7>gjJich`a75 zg*$E5b;hdgAkrHirJHMlMOMCh{iXjVenJI;;}J`uTNmFDdPWDqczSoc~EW$ z<{9j=`xoL{ev-#R@t#poC}R8D>q60dQg+p>awwWHtY01(oyh@s+*E-S9NzlfqhuS> zIFELC)S^1PM-)u4WV>n^yzG-owHrlX^2_3SPy|QLo;ilsD7}V&;t}Xn?Vd={fZ30O zhzfecOoE+wJ2r)3#EgSx6zDF%;Z4)>ybG4rC5IxWZ&88NS8XDW&^{GH?pPz`Wu$1p z?2nghtAi=uN}N!rn3%drHh~4@c#KEb7Oq+Ky-vJn<5`iTWyZni2q_=-bUPabh1K14 zKfx(N7kYHyk;UircHL`Kx)K>Rim;T)9fei9M{9_DxTH79CTY2%SMXq(T$=6t2SUZ+nwD*gtah@y@qb*|0d{!+it4{yxj4KqEgp_@{WjD&F*Dm zAFUXU_14&sgqqpBdKr0S&(iz4mMq~FZOBQvgl$dRG3@rY#4@$@7ZJUX7|V!P)tpLZ=nknz6zfzZP| z7vzXwEPQevQA38ur$=dtiAsDWmz{2|2`R@)arrIDrkYVPEK@G(9zna>+EPyKdrNCi z-R@noNrO=9TknY+De%za*+?Nt0M{aFlxV|3yBraGsefI5L(zxJ5k~QyB9#4v1!SQ_ zIw;8iZEmxWkGR>{IGB!46|<2WD_j<4tFo@|erl;t3r%USVVYFWF!E@?><6`ac-dYA zA^VLexUKC>6N2GSS+!b#;E_>w|Begnt455C`eT=DuwyY#3yLuRTJSznG+=guRU0vz zY!v(14AV!67xkJ^vaY^L`d<5iPadsW`akd*okyzUUp#k2XsmneS~V=p(LTZ?9Oa1J zf-h=sa|c=7_L7|EZPj)n>NkoGN)jyAteS`!L2`=?uYbo_s856l=Lv~F|=LTg5P7ws+7wBcAXvAz% z@I;K<^2fxMXKENR;{+H5W!3ne_PXpfOj=4Y>N92ePtZp>X0>Se+wCp${>MkVg{B_m+BvEW#i22j%L;$<*HB6Nd(R$H3UxhAG zWc%7FB7hWXA}C*fA{ZwB#F6hj;_&kukBBRJF9fSb1fEENQ$!ZT`@AIC^hMRx2o$C3 zgPhEw6N}oakud9aw(t^#Z_+jm{cBX~xSp$+&2BR7EgmfhOW6G=O>0CGj~L25=CZrf zVHB+wKI7^R0dYIl&?-S5_*+gvk)whRrW{eqY;baZ<@*sCCAv))Vz)-H7(Eg#8xjPs zNtC#117;J|-;pCT^r!_?HIl{59~0W#bhQ^JekJoEv8;GDH*%SmG0ke@PqJAbQ$kAP|apuqskCejq_F(ezgw%P%c0VBn z%n#Qh3JSDCW+RVm7v}Enzje|aq-}o)qx?|Jrb(#g#mW=vZ)K9h(|Yr7A7`cwwnU7Q6ohZncO6s;0uAr zwtt1$lw<`v`&2Dr_eB6~;6YCctL9-Dy)WI5c>q^Dexw*6-@^zLzC?;Bj=3Wwc;pc| zcIkQH7znro`~{B2r|}()&=9K#oStCU&X3gBgu{OYy{Zq{;^)kH~4=lF3 zWYZaH6qbdc63p#ZB%8blh3kfpw2Fa>4FQqtUDnc@9NDAw$Q-Md4zs-?BoB`U%zn(M z#!#P4e2tnN%TCiHUBt$18ch_4a)j+c+`LHwyB~{^=1Y?!EN~JLL5@gf*RV^FY^#GQ zlAA(~ysW3K8m;5xW_p7N(NwbQ_Pt2QmC%Uu2$%I1V_PX&#Rx6m??Kn$3D)jzXHytW z`D9xa)s27@V|{ijlBjnmn9ZbwPidy7gWEJ}|ak{iA3eh6+En7C@`Fxz@13QMHdC>E!Z$%BDtSydkz%Mis|M2kAw8)g%tW{I2T z0wGDDVfwpdW51J7uk4q7giA4I*IiFLMMPAHX}B9l@>;dWhFYy;)a8hH`Hdo^M3MaZ zOk%$B6nb8SC?o|FrX?trmEIK_qNcUTic^H(Txk3DH7UwccSiTurfz*`?Xd~n7ASg6 z>2j-Lm1JXlY+bT(w--qw7nhEzdZ$QhNch#H4eLVi<2+)>!cDSq zQ( zV&kY{Y?##nk9f5kwiP_0|8A6Qx1bwEA8$i?4#s)(A{IKEa8lkwwGVR(8_O7h;Br&; z8UevOj}&ZZSA*GTR>B{SM>4AoNrXqLE-ykCSIu^jQA9L0X4hw`4^`&SC?XMjmm_*m zB1Jed;6Z~9vIQh!!9b@-!Dm}jC}N`laJqG*$aYbqD8Z^3f;NgC@~D_`W2^(hg#{+) zbe!CHgn8pyr643VxTl4l!G4&4pgWI1OH{KSRW2qu*9zVvkJ{(uBCS8h2t6wX8jqRi zHpwibTPo&;kQ9X9SB(g}X)bm@xhVj{DZ=xZLdK84%G*qq-li&&3Pn`svEPjZ?(rm! zW-s65=u{<+2@cE!jDX_u{jiV73?VwfhD6MQPb+`2YS73dTMws*E*HL=0Vi=0WsdEt zt3tGE5lFw`k$U{dEmVq17J_tp(EW7WSjnzr10Q{?t-(2~e_ehT9x<|nh^8@RW^*ZJ z->xD=bze22j*&-%87D?D)T=>S5E|9(t42wt*GkjT0IJZIq>BTOtTLzELloiDVJ4XP zfk!+M*e##4u0ur>qI%o?6m?)BHTvmaB(1 zgb>fheL$+bLh~a09`Ok5bbF~#M7I5p ziU!R7c)e!%x4t^2F#|!k#%TSgOF@JyjJ58#YQx*`tDcX z=4-5B$51b{)L*Px0v^3#wmL%GQAY7nA4P_@(M{a+CfUf*P1DljOv=1*0ee_`soUA| z^S!KDazrml-Nr$VEK6al_VGM2d^L)&kC3B2vyMs`>V(|s#@W5`h`5EvB^&5gCqwjv=?bMRARXZzu2FdRAk)nu@6&7E+S~Ccrmz$U5nts3zF)mEHT=tEpc2m+t<3RX%Tv#+|`v9p{J`ogRDtW8l9pc z#zqVsr?q`ctOE28io+0+B(2cFD54Y*MPA@1Qe>W(Q^fYciZBus8v$GGs+JV(6pd9H zw1ZGEQ=bX;6F{Ka#wo&0VZ?(`q$3ZGaXzF+G0RnukpPe0F`GPRn{NY|S~W_VO|0-9 zZg}*j`zf3zp6fhP!avlE;-pjIU_8Q5pcc8XKdhR?42?(FkWkcfN7NJ1?NeU7-x;;~QItJKv4-)5te#VA3`rc}38S%)?SCN!r)qFh~MGqVnwv!hC;{ej7 zZ?-X&$@eUT&fd81esYjzPvB({0VHVMC7Y?FcZMq$wlc4LM}CE(TSN;-gjR@VDWG5QszV%- zJPnDOruCqRArojiJvrz#H_bXl#E*Q)8{QE-LM7^Be!fCch+ELGM0CO9kno5aTdEN| zkI2Va^*Iy~0f#6bM zf27EsrHl04kZg3I8`gy)vS#|2pRZ7Kv$L@Yu{hc@i5?Qb3XxI5K6LAJEkfaU%j89h z2Fx~!>}^p*sP7vT-6fk~jQ0eIq7vtG9?=HC6sG#+5IRyQ?-dB?&UbG?w@P&mEn<^6 z3Qh3y<29|v^F&e(ikh4mk0ja5@w9T>f{@f;+f{FS4UaJ55h*-E)@>gk+4MqygD%-b z;M|K4LMjkBTK<+*2^49fh;J@w5f$u}&%e6+?|Th3K}BV~8Z-xQx03G%5ZGKq6AwcY zUXn>dx9Q@r`#mVD_r(cC28m!BQwl|-A@ngnZ#*I!b>k7y8mfWo#q@X)kD(9)9yN+I zY|b?;4GrWW-Y6O{JAq^y_UUWEm;@9VI5YSh;B7#nhgi)E3BudLcFdQANjX~$+M zs2Y~utz#~0D|;yJHM7OSs_{^V@~ZoN>rodi0(^hOTI3QL zRi4wV5oQ%Ip@5|^JW{u9Yv?Z*tDne{ZYr;e$cxwbwzXj9ElRA%j8%F05wR6zn6fwcj&v^ll3Lr)v-E2tBSlUf? zHU9{wy43pdTm?7?{PZ?$KEecjqsYE}rwAL8?159H8g|cRe}zYP%qF0Y?OOj>Ou@=6 z@ob(8NUL+)6qM{E@`Lr_$fH7HdwhnyM(uK=M*rlX$ONWQgk)o9_jzpEYnsj3=q9K* z?6rH>Az4PCqV0a7#~?wN5JwP*ecA*-A|PUGlra^H^~nE znuZfVgAEoX-%qR<>8^W?QFs&sVO;xOoxEHFFX)G;Tjf^g%S%M zv43nwep|0;b7=@%3p|#&$EY?%*x5j8X1tW7a2`!uI`-6H#kKWlJc1%>3cSz)igaJE z8v6JTeJstM>7dZS_fo zQz;PAs(}(wG+=guRU0rn0Y$cp@<{ezXD8s%fY~2Uk@*dI_L^&~G;-w4e0eBJXJ=cM zB9R=W!)$NC%p*tXFx%^#^YADgW_uL2@d(SGS~`NjW%J>h;6e6NRo)|`>HrS$BQ;~S zqh~1f#)ITYhTbotF(HQ~6UhgWM8U_@lY&+2r3Q_nkJoD+8OlRZI?Q&DJ`a!5VYW9t z-y%ZqyMM@wP$x@oR^vOhegydl?70(5hd1Lv^yL)mjNNYI8^Va;E~s-Hj1ho^@N%t>?j8Fp}xx_dc~MHqMMiil7{FWOM%#Q8d`u!Xxz=nn5Hy;tVj8ws*bOdq<1Oqn={Zm3T)~Y%-wQ>?4dL zW_@%#VywkmZx+`S?$lpeLHsrPAiZUaT0Lqa{0{gjon*S+!fW56LSkYa8F0cg5jo*fPFq zR1wicTRBK?7V|5qnbOP1qsHMoMf7~sKPwb5XVPANMX%km>x^$wV>JwOUPlHnC zLZOS>N3@REF@%w#beL`5C-R77p_Mh%RqIpqzQUs+5~J3w?bi^C2};Z}Ki^#_uYl?iA6< zMe(#=MvClNdcRUcYf;S8mO1RUwr>;--5JbVA{p%d8so+(rS?=Yg}<6Au16K{Vwip# zsuwA;U8IYgN0g)JH9y7j=K$yW>T4e4U9vIQe1eN67wq)Qy9bGHc{0YK-b)=;)ZNuW zqDYZFOP4i@sH^tk4N)Z4|80tH-Sm_R(QehQraE8!ETN;09&I0HARAIP=G&?bnEmk) zEw2S{JW4>32~1x#Dp^8jCYqM1Z-%39lC2q=(aWYr-K)9jd?PGDJ-lN!l`K9ugjFLd z!Oql^qa4|@^6<#^bsmb$@<~IHMVCd8cK^pqw#6|LQS=qe#*THPQ3y#Dsa^GzsfWMc>sf1K#`;3}4T^}R^m+JQ^ zzjNSGI?Q(95tFLL#(6=}%a$eJ*7*BgtIh0{(TD~vvD>W_iDF3C-gV@Nx;u;rZ1%p_ zxVYMeVXu9y50Xk+hpAFmi&s@2$=N+)73;hdiFmELJT4h7IZ@ zJh;AWnn;nMapw`U#;6%=B+Q)Lr7@I7(OboM9nV-lhDVfv6923(K`MMD<^|NfMo}Z9 z?ZW^9R)YEdZxpq^F83&_rt_wmThvIvw*d>h>y|m90z}{a3=+HLMNXKARagI*7zT5^ z82n(%M1qBLbs9FP50d_y@g%Pv7uHP*MO2p3`Djqi>_VNlXYx-a@r@!ziG|u@%Baas zGcnsJB5gy{k_!&L(8Bn$`YAIy)LSz4ih7qoxvEg4iQbnn9)wigtmQKBjz&3R%3jnW zM6=No^_kF09tr8LtA>li{B({sHkMK4iv?W1Y?LDt7~P~$M8iiofr&m*o@hQHr@t0e z-&c(;nMe`C#b|YG_hh{pqDf)Dk-(UW6XCA(!XwG~IB$f)*7|w*4MiWX*F5APk_wMB zz=JK&2-U1HWX0%aSe#hWc|?b9{x>o8RYnjw*;=7-L2V_kRNocquVNnBEan(#_ z8$}<_qjY_c95~sQCl8MX%ucXsCc=4mWZ;~KBHN33D0;(ee5x=Z4m6>f!mTJ~VBYbF z5ZWD&0BJKEI3Jz(HAfs7W^?=zSyPi-wYHNXC9f2=k2&Rqa+$U+^mn6Jv6y_-=ri=OifCH=Npb{wa$mJJ zDqe5$lYvJJ1FFO%qR1pa50A28c5|27%4r2Pb&fo!v5v!^)y-x$iyFKPe{>dTPMsXgB%wEkyk$J0mC^DH% zLs7auNc!u=oc5DqulXTjA}R+(=`efjgM6@#oCM*;t)w~eX)W8!9QHc0QXDOqeLJJB zV787)*T)K~amWH=wLJ8|+}n+|^ZF?l)9A_^QoRh;h{qW8evVa3huKz{BNip$Q98`_ z;}+8JC|w^U(_M=M)nEE=1}CulZBX!oL>6Ilf61&s&&+7Y(x?-B5$%2s?X+CHqPP@T zOw!5$nvWPZJl2W2Y5Xt9lbkPn>;%4{D~z#CH|RA<%bR`M*`kVJ6~wvQUNcenoC34G&`2cZpeUW4ovsg(y;*l^ z9yxMrrODBQ;plj=K7N#1Gx|`RlN=u8*{gz(WQq)*B#2LrTchTveoM}_+!;33yL`w$ zk`ypaihV@zrf&9NA6X_m5s%ElZ#??&cs6O3%Hc#jGQF3FN9kfC*58(B)zV?MqeC7! zN{88Ah~0QZ%pA-P5q6T-l!4lg#3*%)7S3*%mv_u25n}OpCMHwW#+i3!Lu$+*r&tx4 z6~I$H0jBF^z-;U7C|9MhM(i9Lqv*kbt#tHzE}NtTxdf|Bdr)_Fv$H8?4!NUZ`Rll| zayQP+qC#S&jLUhX#!O!oS^gY3T$D!SQ98`_f;D}u9IIw>mWQHrv5|CrkfdPiz9_$Q z$Wc1XwvL=UJn~7jY4)0RlO^I&I?NvXAV1z0G0P#*s-?qh&oAWJYw0lC z6cxj}?6f2nn@{V_!=rSV?Vea39;LIhtuC*~b_yHPPkPL=YUwcB(^hGCl&%kwvExOi z>#r1&ZQb^Tq#P8b!)&YZNW`Obm~FL-iFlMQo^737iFlMQHsTfhVp0k`vhKG$tL6#W zJUmK=+1~J&hezo!+j}na@F*Q-kA09IA7k^Lf;6j^t`Cw^f5n{klR}GF*HWP=2Sw>H z+cU6YQVt%a!)(htCz7LdnC&x`^T<&)JDXt~MS|+D410|s>FFrSR_oVBqBK6`ST(CG z5>YuQ%7)qW8Kjf!Y?$50o9B_EbeNs450WExvq^TkK1fFDr{hsN%ud$_$=t1UtCkM4 z>!B=-PbqYNx<1HuC`%?DjeU?G9?@d{ezv{lrQsqhg=DAegIwoyc6Pcx$koocD)OB} zjG~j7o9R&2E{9~N!)za! zBPONbk$2qXp$NYCPYxcX!)zavooCh3VYW}C$-|>`v5|CrkZZa=$aPH@&ra6|$r%Zb z*h%zSx<1HtOBc^h*9W<#>x1M#f^?FdE}rcthosT8V;|&$Lr$4&?IRHx3(VOrPWQEx zVIHNlL(?XhZ+SbV>f$UC4q2*_aB>zj=dkzlAa@Q#iRX*xc$8{Z_sJD&x<1I&Pee(x zYGWVd12!@_%S+oi#EDZv+=n{%GDgc+jnhDUu9i-HVwNBa+g6RUTsT@|-TdrTP8*qf zwu+%!+p*O^Xk4{)n4PW<6uBaZ}(?x<1JDNQc?!`XD*PE*oa2>x1kk^rhKrZY<`ZC|ztMT_5CX z=lqo&mjbiX^+B$F&R-tMP8S>Ta~1ROD4m_1t`Ble*9W<#>w{d=^+9q_dqL~^D+Ok! z>w{zhZaN;N!|ZhDL9XfgAlLCc$PceQ-qQ6!Zt40UnJAuY_iq*rFLY(V?Cq7UZiM5< z(ydxH%-&wvVk6rto1NVQ*Ak}`do5ib^t`BmvbHIu;rO+bj`XD#Y38#_lbbXLpx;{uU@YxVDT_5C@t`BnaQw;O$ zH7gKFL(zC1G~kIbbXLpx<1G)T^}Sz+-1Y;bbXLpx<1G)-Fc9`hBpmnr|W~< z(wzsnjpspryk1M!2f3v?4{}S_2f3~3Vk7DLAh&dVkXyPw$SqwT%0VAZnK`fcg@Ah&dV zkXyPw$SqwT(FTC^Gk1vncZ$Zp>&;Rx7zy0#p$K%U?`NRMD<*$Eu{?}jr^rwIQ z>mSCezI^$Y*Yy78zyEh0K>!@%8Dq;@O{|T-^?2M;QGE(+(V2dk^aR7mpNz7#l8pIc zwsr5z+V(OQ*XQC+ueH2WZ}EE0%)vdZ!i2fF`!!wXVsmk)lR>!F2lsle3oRct*%~Pt z=9)a1;Prg%Ui`RB`;!AaO{eYaKoR1ncZ?$9r~7KTK_-09lVF zU8KmEp?ek{{S-yhbj_31yE1hc>zvX~DB>~KbD7yhvkwxVpl7a4ACaPAuE|gGXkr}c zX6MFE%&wnTj*>GTF^>M)t>=^_eo^*oub ze5|_@c)hMx*7TqL{qN}?`38Oa|2_x)AA7<7WBtVcA6dtL^xA;`zpsGD@1MheX5C!R z-A0=;CVk|Ki5A6)hski2t0Db)tiu zqGNlaR15*pNH_dvn&pimj^bE6uRG(QT<2?Z+m=&67!TgMPr!c+bHGpJM~X)L|2c{# zP69g3+Mb`7w&!(-M-6R(Udyq9w!~cbT5c67vTrX+i%0TvJbH1alP42 z+jMoUjec6s>V8FvOhW!S6v8my|4G$kxPyP>x|NmpUelzSB z7-8N0z44zF=N|mWJKR3){~rSKfAHdh{|JCY-+z7%|L6I@qW6JL$NHSk#iK1VkZpLc z-9N9Kq7?0a0tK_x(1C3jX2e_r6F zVKNr{%_C7bB~mo&*z<=}`mZn%4DY9qjebDy9dnVAk zBBlKZ|9_50(?v|os%UoXe+GJOtD`NhfoG8AGA-v`+an{7M*ROtiWUUJ5dOrDz>6yp zsj4FSe>)ZM9sDO1@Ur;-N;FvbkL&h{ z|NkJQ|InX3x&SmV5Egtb{%_W^E}P=MZMJ&(^BmYV;y>qTUf{Mt-ZXL*kKKD5QY@iZWQ29v9=RY_$+1@@T;S$3%XFvjgqzNghY< z&p!4N66-mVeF-}9coP4|UTsQ|_&?`2az#bkjbsbajHAc4iG0N2MqqFDT)49eSnGq=1=|ai}V}*hwFa}xd~bR zztjJ-&ffKATEwg5O!QUxL05Xdzv}SBi;GSl^ZCS#a|rHYdfxOX|XK@ z-)20WM&QLu0%3dcS0hEA`rm^NH%lY(=u`iHpGTki|2IVE-~QIW{*OQW^$*kU{$<)e zO#g3W(7XSC9Mb>H7XH-#zy0ce`SR!jAl+1dzNY^zSXQq1mj7Ss|4u3Z+RavqudbJO zBB1r;T)S?g63kyq+fFN|TiRJ5)af0|Ne<9d-7+tf;wi9*<|F=#=6luQ1`)SSkBS0m z+hsbRWdF^1B0Rn0rCZFK1fEl%yP)g+b)g8AzVz(X!~;(YP@m6ZrjDQ#78HthobPr3 zO{8el|1%~CX-8AS=Y-*~SVi9hYd|b=9#Ot=qloO^wOH_=#8aomM$KMNuAWIrRvtaz zF3FTiex%4AZ9L)*vK+)N{ZN!ijMn0(k7b~U8kieJ3pFp^B>+Y1Nfk^}4Xo*FIr)FR zGZf9#biT((2LJy7*-zr`woD{xIkmNi!6E)n z(1!@H%Ml#9-eV*t!XjLZq4Wo1%MU$(B8r!MUgUQvB3n&hrgA}lO5Etx!ZgQ|lE^(K zIw(@z-zhQ?zEk84{)HlP!Sxy6=Mjdao5eddTiB77*~TCxVm`f8R#YT=Ip%YH&uk3( zzwziFqiBOEI~H_f3Nf*TYFo?xvum$?rS8=zB8MwU(wB{rZ31)S5e3PODdG|N2@~{h zui6TBsgShU+6&7+9TX&25-0}S4l0X08MF|%rh06k$g0^20Y#2Ztbgib8$~dsT5IoM=oP6&OlwY{UTO4@+dlcMY87^-0*bygM=98 z4S08b3r9Ld>r_&BzSmR{jR#V{4uS(kYz$u}DmEsYub`UkYd>o&Hmus%&-0kc8&c(F z%XA!1O3JLl;6b*=@ke)Aq2Ca*?0)L|DAK4Dv1%7JdYe}fQeQ~Uq48Tw@uHBtJSkFS zc%_?^Rr|{BKOLUFEk^=r{%0j9RHMKzijZy9CTcjQ%UO0zNKsXSk)k)uo@cmXstLvW zL>qcPTVsi@nsiR&(Q#3uVe~^_acdjP#1yog)og>=xWFX&#EVGLh}qH$)My%TqSsz? zh-(j8WYlX&`aWCdyHqRtbo1OV2|L>2oj`nA%EZdcNRd6dt=i4E`*wJeyZpe_-@Z6f zWcxY~MFxc*Ows=f`}Xr0-{wFu|K~jZ-!!TJYoUDL%j2{E>)UJh&-k?Ze? z{lEE1wRf`)P|cWeq+Hv*7a|R&g@lrvv*xdh=9U3tlRYri4oWjhZ6io8PXfJYiCmNv zC4G2{x^+O@N7E7IiTY6fANtFH7<1;>yC;F0;1uXCbT0X8J(FtsYqu%Pn5a8S$=oX_ zTK3gv?8v%V*6-KXhws+SqJk=Z$`=wv)Yec4RbNuu&I=Ft zLJ{RisBXKM?#kEp{rXQO#b0z4)IWP*E0D)_t8BCY@f+?GU95zueRAzD74LUL9ovG+ zEu)Cu5Hj3vt2Wva)cHQoxfc#&SW*jSaedZS9g#&Zl8?N!U%tZq6^z>Wucl8%BH}IKh|dQZBM)i zLIBMmWD$uuv_VNxvTb?(85EH?Sjn@Q>!8dAt%GKhB7yYG5q)tpo;1m{jGn|}uqCj} z|8X8I#4bqvEzSR9L7DNx{;nk8|6%Z*W)NaSQ+ELZ=+nrfH~;S^DB`=|bYPrU5)d3* zWXipbBB;ejZZE+jpz2kRAPf|}`+s5M)OtU1Cd8>{vW#ZL_HR!u`D1Yfk6|i?;#|i9y*uX)lwVhzF2ro z0HmH>+uf}H3{({4ixe3Y`l=zzbMLgHw3qG;i&eaN?RdbqRijOLpKTwoz-VFszyyat z(2h>3Ulws-P70lEdKoDiF#88QI_~lVSAYBBNRcg1GsmB>dipE$nCA;z~jUpNniQ0RL zg7kn` z@kOjGaf*~LFbc&ZyjQw*nx@0#V|WZ~bRJ>(_?-TilCLY%IL1{QZ3#@W7)xI8ps;OC zzt^cTok#Rx-YCKkQQJ;ka{NE+ZLH=>5%$(PP4pQVfduC1@hlfd9@(>W6D^e}g7wV= zc|g%gsKPAQ?^2{}mQh6Nh$1Z<+DZbB#g3KS2OSXPz}R`?(O^sb6h$f=QzoQwVUl~z zy0%p#^QAEZr{^SKAlxs49C>6C^3UKAKBpwNQ-t$^NVfDE{vS>}lZkBANZ}w!g(Z<9 zvwv?CQAeQH{78;4Wo>Q0y=u5uq?TUhPpwEcX7brcz-8t}q>hau>Q-=4-aH8t7(Kqo z5yk)NGSh2*HkI(dd^TF`kL!|6KY(f|REJY$b5HsDdm@Pd$}u9)McoAGTRfz7o0=Azf3<39)qG@P}CJFJ>T zYRWANMU*^({I*O)z-X=W&SJGqbkQ$Nb# z5}>smc~+<0waA#YohNElO^!|+$(@v`Z!Qp%lzKv87 zWo~i)BlZ>^o$2BSPjm`I(Odox4{tV4h%zJs%j5&i>pT9p~E6sr_wgfG()LiMAuVP=FDKus`k?S43V$k z_GoWC?9qCpEUM*|*pGKT8q0BHVNa3DsxH;m1I=ms)=YiCQ@*Qbu+VA9|$7MEIXU5!|IZ&^H(E zKaxzRGz7v42qfN5^<|}(q!~~^AVDu9k8FAF6uA+qRRdt`s&B8FxIpfIZ*DqvJE?4h zy^_E%C}y2d+g@K129ccC<46NV9x!l<&I6akQg{TM

=v0hin*S$A1RIRd*p*0NHl zN3G!1m;$mf_6`r#DPrgy9cy}Wq)4)3Kl*QGZN$trsiTW@i|xoMRG=1$u6wpk!)VD@ z*Bch#(3D3b0hb=XqRELek}Fs-%F$Q+zv3gen?CR>h`X7$@|dw-J-}5>!i_-dd-g_sT9OC?FfDjn)cOKv8)<1n&CtJTNNae=C$n( z0Fmn_Yg#`onwE`Oo)jq>F#Dr?n@XjAyX8|}r0_@w%>F1I{r1-F=M%oifnR_9%b$P! z-Jho8w`>3V-uyS>^nLyhozU|CFzmlPKK;M%t=`Xn{%`^4i1pR}e;a^SF8gNxpXN8K zcE8<_tP3?tHnWpRt(>tQ-KNc<1e5F4GR4VeS=d@Q?C>m`E1}WeWSfb-Wst0K>tL?!-5GCX<`nC2H z1C_zDdR@#JQV@$-3!495n%k-zkpZF;FV5XHkq~m%K@?$un051Q zipV*WWWXb>Bv9H)J*dyfCb7hxplPyxN@|WyH!4>3GEy}9e}y7XD-<4){Q$+>B;5v^Mv82ki+4HX$UM6=6pjAh$M3Z<|CfLw z+eLX+Egfc${$GMs8!$ToMFVChplHDC1QeyiY!9lW+5NKxRq{||ah*IArNeCRSI)yD zv&9-kO#Zqki1a)QK~@$2*p9@$EvX+}-K<*m&w0?RoTOr{byRFIwf;K1Y=i^@A@PQQ zN(9jvQcGt3=2T;I|9->qzdz*vV+I%hf8Rg-|DX5nzkdh!|4jlVd0)%_{@won$LqIG z|6jRUE#%&2 fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" echo "<-- radmon_verf_angle.sh" exit ${err} diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcoef.sh b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcoef.sh index 93c56226b0..ee81c98c1d 100755 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcoef.sh +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcoef.sh @@ -72,10 +72,6 @@ # Command line arguments. export PDATE=${1:-${PDATE:?}} -scr=radmon_verf_bcoef.sh -msg="${scr} HAS STARTED" -postmsg "$jlogfile" "$msg" - netcdf_boolean=".false." if [[ $RADMON_NETCDF -eq 1 ]]; then netcdf_boolean=".true." @@ -246,7 +242,5 @@ if [[ "$VERBOSE" = "YES" ]]; then echo $(date) EXITING $0 with error code ${err} >&2 fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" exit ${err} diff --git a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcor.sh b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcor.sh index cfba7367de..2d1faefff0 100755 --- a/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcor.sh +++ b/util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/ush/radmon_verf_bcor.sh @@ -71,10 +71,6 @@ # Command line arguments. export PDATE=${1:-${PDATE:?}} -scr=radmon_verf_bcor.sh -msg="${scr} HAS STARTED" -postmsg "$jlogfile" "$msg" - if [[ "$VERBOSE" = "YES" ]]; then set -ax @@ -239,8 +235,5 @@ if [[ "$VERBOSE" = "YES" ]]; then echo $(date) EXITING $0 error code ${err} >&2 fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" - exit ${err} diff --git a/util/Radiance_Monitor/parm/RadMon_config b/util/Radiance_Monitor/parm/RadMon_config index 908c2553a5..ae86fc2fe1 100644 --- a/util/Radiance_Monitor/parm/RadMon_config +++ b/util/Radiance_Monitor/parm/RadMon_config @@ -20,7 +20,7 @@ export MONITOR=radmon # you checked out only the Radiance_Monitor portion of the branch then # MY_RADMON should point to that. # -export MY_RADMON=${MY_RADMON:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Radiance_Monitor} +export MY_RADMON=${MY_RADMON:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/ProdGSI/util/Radiance_Monitor} # # The MY_TANKDIR will be the location for the extracted data files and @@ -28,7 +28,7 @@ export MY_RADMON=${MY_RADMON:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/Pr # and the succedding scripts will construct and use subdirectories under # this location. # -export MY_TANKDIR=${MY_TANKDIR:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/nbns} +export MY_TANKDIR=${MY_TANKDIR:-/scratch1/NCEPDEV/da/Edward.Safford/nbns} export RUN=${RUN:-gdas} @@ -67,16 +67,16 @@ export WEBDIR=${WEBDIR:-/home/people/emc/www/htdocs/gmb/gdas/radiance/esafford} ############################################################################### ############################################################################### -export MY_MACHINE=wcoss_d +export MY_MACHINE=hera export LITTLE_ENDIAN=${LITTLE_ENDIAN:-0} # # Log and work space definitions # -export MY_PTMP=${MY_PTMP:-/gpfs/dell2/ptmp} +export MY_PTMP=${MY_PTMP:-/scratch2/NCEPDEV/stmp3} export PTMP_USER=${PTMP_USER:-${MY_PTMP}/${LOGNAME}} -export MY_STMP=${MY_STMP:-/gpfs/dell2/stmp} +export MY_STMP=${MY_STMP:-/scratch2/NCEPDEV/stmp1} export STMP_USER=${STMP_USER:-${MY_STMP}/${LOGNAME}} export LOGSverf_rad=${LOGSverf_rad:-${PTMP_USER}/logs} @@ -184,39 +184,19 @@ elif [[ $MY_MACHINE = "cray" ]]; then export COMPRESS="gzip -f" export UNCOMPRESS="gunzip -f" -elif [[ $MY_MACHINE = "theia" ]]; then +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 - NWPROD=${NWPROD:-/scratch4/NCEPDEV/global/save/glopara/nwpara/util} - NWPRODush=${NWPRODush:=${NWPROD}/ush} - NWPRODexec=${NWPRODexec:=${NWPROD}/exec} - export NDATE=${NDATE:-${NWPRODexec}/ndate} - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" - export LOADLQ="squeue -u $LOGNAME" - - #------------------------------------------------------------------------ - # The links below are a hack around the modules that are available - # on the wcoss ibm & cray machines but not here on theia. The alternative - # was a bunch of contitional executions within the scripts to avoid the - # nco mandated log and error requirements. - #------------------------------------------------------------------------ + export NDATE=/home/Edward.Safford/bin/ndate + export COMPRESS=${COMPRESS:-gzip} + export UNCOMPRESS=${UNCOMPRESS:-"gunzip -f"} + prevday=`$NDATE -24 $PDATE` export PDYm1=`echo $prevday | cut -c1-8` - ln -s ${NWPRODush}/startmsg.sh ${STMP_USER}/startmsg - ln -s ${NWPRODush}/postmsg.sh ${STMP_USER}/postmsg - ln -s ${NWPRODush}/prep_step.sh ${STMP_USER}/prep_step - ln -s ${NWPRODush}/err_chk.sh ${STMP_USER}/err_chk - export PATH=$PATH:${STMP_USER} - - #------------------------------------------------------------------------ - # err_chk "helpfully" calls postmsg.sh directly so we need to override - # the utilscript location on theia to defeat err_chk's helpfulness and - # avoid a fatal error. - #------------------------------------------------------------------------ - export utilscript=${utilscript:-${NWPRODush}} - - + fi