From c94bc72ff410b48c325abbfe92c9fcb601d89aed Mon Sep 17 00:00:00 2001 From: David Huber <69919478+DavidHuber-NOAA@users.noreply.github.com> Date: Thu, 30 Nov 2023 11:52:16 -0500 Subject: [PATCH 1/4] Upgrade to spack-stack libraries on non-production machines (#624) Co-authored-by: Natalie Perlin Co-authored-by: DavidHuber-NOAA Co-authored-by: RussTreadon-NOAA --- .github/workflows/gcc.yml | 31 +++--- .github/workflows/intel.yml | 47 ++++---- ci/spack.yaml | 4 +- modulefiles/gsi_cheyenne.gnu.lua | 36 +++--- modulefiles/gsi_cheyenne.intel.lua | 32 +++--- modulefiles/gsi_common.lua | 16 +-- modulefiles/gsi_gaea.lua | 24 ++-- modulefiles/gsi_hera.gnu.lua | 22 ++-- modulefiles/gsi_hera.intel.lua | 21 ++-- modulefiles/gsi_hercules.lua | 26 +++++ modulefiles/gsi_jet.lua | 22 ++-- modulefiles/gsi_orion.lua | 21 ++-- modulefiles/gsi_s4.lua | 23 ++-- modulefiles/gsi_wcoss2.lua | 28 ++++- regression/regression_param.sh | 137 ++++++++++++++--------- regression/regression_var.sh | 19 +++- ush/detect_machine.sh | 2 + ush/module-setup.sh | 7 ++ ush/sub_hercules | 170 +++++++++++++++++++++++++++++ ush/sub_orion | 2 + 20 files changed, 485 insertions(+), 205 deletions(-) create mode 100644 modulefiles/gsi_hercules.lua create mode 100755 ush/sub_hercules diff --git a/.github/workflows/gcc.yml b/.github/workflows/gcc.yml index 6ba8ef3295..1f6fa3afcd 100644 --- a/.github/workflows/gcc.yml +++ b/.github/workflows/gcc.yml @@ -15,9 +15,9 @@ env: # The jobs are split into: # 1. a dependency build step (setup), and -# 2. a GSI build step (build) +# 2. a GSI build step (gsi) # The setup is run once and the environment is cached, -# so each build of GSI can reuse the cached dependencies to save time (and compute). +# so each subsequent build of GSI can reuse the cached dependencies to save time (and compute). jobs: setup: @@ -25,11 +25,11 @@ jobs: steps: # Checkout the GSI to get the ci/spack.yaml file - - name: checkout-gsi + - name: checkout if: steps.cache-env.outputs.cache-hit != 'true' - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: - path: GSI + path: gsi # Cache spack, compiler and dependencies - name: cache-env @@ -39,33 +39,34 @@ jobs: path: | spack ~/.spack - key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }} # Install dependencies using Spack - name: install-dependencies-with-spack if: steps.cache-env.outputs.cache-hit != 'true' run: | sudo apt-get install cmake - git clone -c feature.manyFiles=true https://github.com/NOAA-EMC/spack.git + git clone -c feature.manyFiles=true https://github.com/JCSDA/spack.git source spack/share/spack/setup-env.sh - spack env create gsi-env GSI/ci/spack.yaml + spack env create gsi-env gsi/ci/spack.yaml spack env activate gsi-env spack compiler find + sudo apt install cmake spack external find spack add mpich@3.4.2 spack concretize spack install -v --fail-fast --dirty spack clean -a - build: + gsi: needs: setup runs-on: ubuntu-latest steps: - - name: checkout-gsi - uses: actions/checkout@v3 + - name: checkout + uses: actions/checkout@v4 with: - path: GSI + path: gsi - name: cache-env id: cache-env @@ -74,13 +75,13 @@ jobs: path: | spack ~/.spack - key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }} - - name: build-gsi + - name: build run: | source spack/share/spack/setup-env.sh spack env activate gsi-env - cd GSI + cd gsi mkdir -p build && cd build cmake -DCMAKE_INSTALL_PREFIX=../install -DGSI_MODE=Regional -DENKF_MODE=GFS -DBUILD_REG_TESTING=OFF .. make -j2 VERBOSE=1 diff --git a/.github/workflows/intel.yml b/.github/workflows/intel.yml index d48c00a21e..d21420687a 100644 --- a/.github/workflows/intel.yml +++ b/.github/workflows/intel.yml @@ -18,21 +18,30 @@ env: # The jobs are split into: # 1. a dependency build step (setup), and -# 2. a GSI build step (build) +# 2. a GSI build step (gsi) # The setup is run once and the environment is cached, -# so each build of GSI can reuse the cached dependencies to save time (and compute). +# so each subsequent build of GSI can reuse the cached dependencies to save time (and compute). jobs: setup: runs-on: ubuntu-latest steps: + # Free up disk space + - name: free-disk-spack + run: | + df -h + sudo swapoff -a + sudo rm -f /swapfile + sudo apt clean + docker rmi $(docker image ls -aq) + # Checkout the GSI to get the ci/spack.yaml file - - name: checkout-gsi + - name: checkout if: steps.cache-env.outputs.cache-hit != 'true' - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: - path: GSI + path: gsi # Cache spack, compiler and dependencies - name: cache-env @@ -43,16 +52,15 @@ jobs: spack ~/.spack /opt/intel - key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }} - name: install-intel-compilers - if: steps.cache-env.outputs.cache-hit != 'true' run: | wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list sudo apt-get update - sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic + sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran-2023.2.1 intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-2023.2.1 sudo apt-get clean echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile @@ -62,31 +70,32 @@ jobs: run: | sudo mv /usr/local/ /usr_local_mv sudo apt-get install cmake - git clone -c feature.manyFiles=true https://github.com/NOAA-EMC/spack.git + git clone -c feature.manyFiles=true https://github.com/JCSDA/spack.git source spack/share/spack/setup-env.sh - spack env create gsi-env GSI/ci/spack.yaml + spack env create gsi-env gsi/ci/spack.yaml spack env activate gsi-env spack compiler find + sudo apt install cmake spack external find spack add intel-oneapi-mpi spack concretize spack install -v --fail-fast --dirty spack clean -a - build: + gsi: needs: setup runs-on: ubuntu-latest steps: - - name: checkout-gsi - uses: actions/checkout@v3 - with: - path: GSI - - name: install-intel run: | echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile + - name: checkout + uses: actions/checkout@v4 + with: + path: gsi + - name: cache-env id: cache-env uses: actions/cache@v3 @@ -95,13 +104,13 @@ jobs: spack ~/.spack /opt/intel - key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }} - - name: build-gsi + - name: build run: | source spack/share/spack/setup-env.sh spack env activate gsi-env - cd GSI + cd gsi mkdir -p build && cd build cmake -DCMAKE_INSTALL_PREFIX=../install -DGSI_MODE=Regional -DENKF_MODE=GFS -DBUILD_REG_TESTING=OFF .. make -j2 VERBOSE=1 diff --git a/ci/spack.yaml b/ci/spack.yaml index 0fc66547e5..deacdff0b5 100644 --- a/ci/spack.yaml +++ b/ci/spack.yaml @@ -6,8 +6,8 @@ spack: - intel - gcc@10:10 specs: - - netcdf-c@4.7.4 - - netcdf-fortran@4.5.3 + - netcdf-c@4.9.2 + - netcdf-fortran@4.6.0 - bufr@11.7.0 - bacio@2.4.1 - w3emc@2.9.2 diff --git a/modulefiles/gsi_cheyenne.gnu.lua b/modulefiles/gsi_cheyenne.gnu.lua index 43e6aaf02c..1d903082a8 100644 --- a/modulefiles/gsi_cheyenne.gnu.lua +++ b/modulefiles/gsi_cheyenne.gnu.lua @@ -1,30 +1,32 @@ help([[ ]]) -load("cmake/3.22.0") -load("python/3.7.9") -load("ncarenv/1.3") -load("gnu/11.2.0") -load("mpt/2.25") -load("ncarcompilers/0.5.0") -unload("intel") -unload("netcdf") -prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/hpc-stack/gnu11.2.0/modulefiles/stack") +unload("ncarenv/1.3") +unload("intel/19.1.1") +unload("ncarcompilers/0.5.0") +unload("mpt/2.25") +unload("netcdf/4.8.1") -load("hpc/1.2.0") -load("hpc-gnu/11.2.0") -load("hpc-mpt/2.25") +prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core") +prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc") -load("gsi_common") +local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" +local stack_gnu_ver=os.getenv("stack_gnu_ver") or "10.1.0" +local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.1" +local cmake_ver=os.getenv("cmake_ver") or "3.22.0" +load(pathJoin("stack-gcc", stack_gnu_ver)) +load(pathJoin("stack-openmpi", stack_openmpi_ver)) +load(pathJoin("stack-python", stack_python_ver)) +load(pathJoin("cmake", cmake_ver)) load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) load(pathJoin("openblas", os.getenv("openblas_ver") or "0.3.23")) -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_fix/fix") +load("gsi_common") -pushenv("CC", "mpicc") -pushenv("FC", "mpif90") -pushenv("CXX", "mpicxx") +pushenv("CFLAGS", "-xHOST") +pushenv("FFLAGS", "-xHOST") +pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") whatis("Description: GSI environment on Cheyenne with GNU Compilers") diff --git a/modulefiles/gsi_cheyenne.intel.lua b/modulefiles/gsi_cheyenne.intel.lua index 26ed666695..8c328e2b34 100644 --- a/modulefiles/gsi_cheyenne.intel.lua +++ b/modulefiles/gsi_cheyenne.intel.lua @@ -1,26 +1,32 @@ help([[ ]]) -load("cmake/3.22.0") -load("python/3.7.9") -load("ncarenv/1.3") -load("intel/2022.1") -load("mpt/2.25") -load("ncarcompilers/0.5.0") +unload("ncarenv/1.3") +unload("intel/19.1.1") +unload("ncarcompilers/0.5.0") +unload("mpt/2.25") +unload("netcdf/4.8.1") -prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/hpc-stack/intel2022.1/modulefiles/stack") +prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core") +prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc") -load("hpc/1.2.0") -load("hpc-intel/2022.1") -load("hpc-mpt/2.25") -load("mkl/2022.1") +local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" +local stack_intel_ver=os.getenv("stack_intel_ver") or "19.1.1.217" +local stack_mpi_ver=os.getenv("stack_mpi_ver") or "2019.7.217" +local cmake_ver=os.getenv("cmake_ver") or "3.22.0" -load("gsi_common") +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-mpi", stack_mpi_ver)) +load(pathJoin("stack-python", stack_python_ver)) +load(pathJoin("cmake", cmake_ver)) -load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) +load("gsi_common") +load(pathJoin("prod-util", os.getenv("prod_util_ver") or "1.2.2")) pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230911") pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") +pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") + whatis("Description: GSI environment on Cheyenne with Intel Compilers") diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua index c54f6ddb92..d3365a98dc 100644 --- a/modulefiles/gsi_common.lua +++ b/modulefiles/gsi_common.lua @@ -2,22 +2,24 @@ help([[ Load common modules to build GSI on all machines ]]) -local netcdf_ver=os.getenv("netcdf_ver") or "4.7.4" +local netcdf_c_ver=os.getenv("netcdf_c_ver") or "4.9.2" +local netcdf_fortran_ver=os.getenv("netcdf_fortran_ver") or "4.6.0" local bufr_ver=os.getenv("bufr_ver") or "11.7.0" local bacio_ver=os.getenv("bacio_ver") or "2.4.1" -local w3emc_ver=os.getenv("w3emc_ver") or "2.9.2" +local w3emc_ver=os.getenv("w3emc_ver") or "2.10.0" local sp_ver=os.getenv("sp_ver") or "2.3.3" -local ip_ver=os.getenv("ip_ver") or "3.3.3" +local ip_ver=os.getenv("ip_ver") or "4.3.0" local sigio_ver=os.getenv("sigio_ver") or "2.3.2" local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" local ncio_ver=os.getenv("ncio_ver") or "1.1.2" local crtm_ver=os.getenv("crtm_ver") or "2.4.0" -local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.1" +local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2" -load(pathJoin("netcdf", netcdf_ver)) +load(pathJoin("netcdf-c", netcdf_c_ver)) +load(pathJoin("netcdf-fortran", netcdf_fortran_ver)) load(pathJoin("bufr", bufr_ver)) load(pathJoin("bacio", bacio_ver)) @@ -27,7 +29,7 @@ load(pathJoin("ip", ip_ver)) load(pathJoin("sigio", sigio_ver)) load(pathJoin("sfcio", sfcio_ver)) load(pathJoin("nemsio", nemsio_ver)) -load(pathJoin("wrf_io", wrf_io_ver)) +load(pathJoin("wrf-io", wrf_io_ver)) load(pathJoin("ncio", ncio_ver)) load(pathJoin("crtm", crtm_ver)) -load(pathJoin("ncdiag",ncdiag_ver)) +load(pathJoin("gsi-ncdiag",ncdiag_ver)) diff --git a/modulefiles/gsi_gaea.lua b/modulefiles/gsi_gaea.lua index a7a2454eff..ef6b9ddba7 100644 --- a/modulefiles/gsi_gaea.lua +++ b/modulefiles/gsi_gaea.lua @@ -1,20 +1,28 @@ help([[ ]]) -load("cmake/3.20.1") +unload("intel") +unload("cray-mpich") +unload("cray-python") +unload("darshan") -prepend_path("MODULEPATH","/lustre/f2/dev/role.epic/contrib/hpc-stack/intel-classic-2022.0.2/modulefiles/stack") -load(pathJoin("hpc", os.getenv("hpc_ver") or "1.2.0")) +prepend_path("MODULEPATH", "/lustre/f2/dev/wpo/role.epic/contrib/spack-stack/spack-stack-1.4.1-c4/envs/unified-env/install/modulefiles/Core") +prepend_path("MODULEPATH", "/lustre/f2/pdata/esrl/gsd/spack-stack/modulefiles") -load(pathJoin("intel-classic", os.getenv("intel_classic_ver") or "2022.0.2")) -load(pathJoin("cray-mpich", os.getenv("cray_mpich_ver") or "7.7.20")) -load(pathJoin("hpc-intel-classic", os.getenv("hpc_intel_classic_ver") or "2022.0.2")) -load(pathJoin("hpc-cray-mpich", os.getenv("hpc_cray_mpich_ver") or "7.7.20")) +local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" +local stack_cray_mpich_ver=os.getenv("stack_cray_mpich_ver") or "7.7.20" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" + +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-cray-mpich", stack_cray_mpich_ver)) +load(pathJoin("stack-python", stack_python_ver)) +load(pathJoin("cmake", cmake_ver)) load("gsi_common") local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("prod_util", prod_util_ver)) +load(pathJoin("prod-util", prod_util_ver)) -- Needed at runtime: load("alps") diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index 37504485e3..550b01ee7b 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -1,20 +1,20 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/hpc-stack/libs/gnu-9.2/modulefiles/stack") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +--Needed for openmpi build +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/jcsda/jedipara/spack-stack/modulefiles") -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local gnu_ver=os.getenv("gnu_ver") or "9.2.0" -local hpc_gnu_ver=os.getenv("hpc_gnu_ver") or "9.2" -local hpc_mpich_ver=os.getenv("hpc_mpich_ver") or "3.3.2" -local cmake_ver=os.getenv("cmake_ver") or "3.20.1" +local python_ver=os.getenv("python_ver") or "3.10.8" +local stack_gnu_ver=os.getenv("stack_gnu_ver") or "9.2.0" +local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.5" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -local openblas_ver=os.getenv("openblas_ver") or "0.3.23" +local openblas_ver=os.getenv("openblas_ver") or "0.3.19" -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("gnu", gnu_ver)) -load(pathJoin("hpc-gnu", hpc_gnu_ver)) -load(pathJoin("hpc-mpich", hpc_mpich_ver)) +load(pathJoin("stack-gcc", stack_gnu_ver)) +load(pathJoin("stack-openmpi", stack_openmpi_ver)) +load(pathJoin("python", python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index 619d0e76c9..abdc6e5623 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -1,25 +1,20 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/miniconda3/modulefiles") -miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" -load(pathJoin("miniconda3", miniconda3_ver)) +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/hpc-stack/libs/intel-2022.1.2/modulefiles/stack") - -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" -local cmake_ver=os.getenv("cmake_ver") or "3.20.1" +local python_ver=os.getenv("python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("hpc-intel", hpc_intel_ver)) -load(pathJoin("hpc-impi", hpc_impi_ver)) +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") - load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") diff --git a/modulefiles/gsi_hercules.lua b/modulefiles/gsi_hercules.lua new file mode 100644 index 0000000000..bf29bc21db --- /dev/null +++ b/modulefiles/gsi_hercules.lua @@ -0,0 +1,26 @@ +help([[ +]]) + +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") + +local stack_python_ver=os.getenv("stack_python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.9.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.9.0" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" +local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" + +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", stack_python_ver)) +load(pathJoin("cmake", cmake_ver)) + +load("gsi_common") +load(pathJoin("prod_util", prod_util_ver)) +load("intel-oneapi-mkl/2022.2.1") + +pushenv("CFLAGS", "-xHOST") +pushenv("FFLAGS", "-xHOST") + +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230911") + +whatis("Description: GSI environment on Hercules with Intel Compilers") diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua index c9e5e90680..20b80ff61a 100644 --- a/modulefiles/gsi_jet.lua +++ b/modulefiles/gsi_jet.lua @@ -1,31 +1,25 @@ help([[ ]]) -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/miniconda3/modulefiles") -miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" -load(pathJoin("miniconda3", miniconda3_ver)) +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/hpc-stack/libs/intel-2022.1.2/modulefiles/stack") - -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" -local cmake_ver=os.getenv("cmake_ver") or "3.20.1" +local python_ver=os.getenv("python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("hpc-intel", hpc_intel_ver)) -load(pathJoin("hpc-impi", hpc_impi_ver)) +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") - load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2") pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2") - pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20230911") whatis("Description: GSI environment on Jet with Intel Compilers") diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.lua index e75a01ef5e..80ec342c93 100644 --- a/modulefiles/gsi_orion.lua +++ b/modulefiles/gsi_orion.lua @@ -1,25 +1,20 @@ help([[ ]]) -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/contrib/orion/miniconda3/modulefiles") -miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" -load(pathJoin("miniconda3", miniconda3_ver)) +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/contrib/orion/hpc-stack/intel-2022.1.2/modulefiles/stack") - -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" -local cmake_ver=os.getenv("cmake_ver") or "3.22.1" +local stack_python_ver=os.getenv("python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("hpc-intel", hpc_intel_ver)) -load(pathJoin("hpc-impi", hpc_impi_ver)) +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", stack_python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") - load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.lua index 03c21e708d..a60ea3c16e 100644 --- a/modulefiles/gsi_s4.lua +++ b/modulefiles/gsi_s4.lua @@ -1,23 +1,20 @@ help([[ ]]) -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1" -local miniconda_ver=os.getenv("miniconda_ver") or "3.8-s4" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" - -prepend_path("MODULEPATH", "/data/prod/hpc-stack/modulefiles/stack") +prepend_path("MODULEPATH", "/data/prod/jedi/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") -load("license_intel/S4") -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("hpc-intel", hpc_intel_ver)) -load(pathJoin("hpc-impi", hpc_impi_ver)) +local python_ver=os.getenv("python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.0" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" +local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("miniconda", miniconda_ver)) +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", python_ver)) +load(pathJoin("cmake", cmake_ver)) load("gsi_common") - load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-march=ivybridge") diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.lua index e5f4c7b812..8dde986e58 100644 --- a/modulefiles/gsi_wcoss2.lua +++ b/modulefiles/gsi_wcoss2.lua @@ -9,6 +9,20 @@ local cmake_ver= os.getenv("cmake_ver") or "3.20.2" local python_ver=os.getenv("python_ver") or "3.8.6" local prod_util_ver=os.getenv("prod_util_ver") or "2.0.10" +local netcdf_ver=os.getenv("netcdf_ver") or "4.7.4" +local bufr_ver=os.getenv("bufr_ver") or "11.7.0" +local bacio_ver=os.getenv("bacio_ver") or "2.4.1" +local w3emc_ver=os.getenv("w3emc_ver") or "2.9.2" +local sp_ver=os.getenv("sp_ver") or "2.3.3" +local ip_ver=os.getenv("ip_ver") or "3.3.3" +local sigio_ver=os.getenv("sigio_ver") or "2.3.2" +local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" +local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" +local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" +local ncio_ver=os.getenv("ncio_ver") or "1.1.2" +local crtm_ver=os.getenv("crtm_ver") or "2.4.0" +local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.1" + load(pathJoin("PrgEnv-intel", PrgEnv_intel_ver)) load(pathJoin("intel", intel_ver)) load(pathJoin("craype", craype_ver)) @@ -18,7 +32,19 @@ load(pathJoin("python", python_ver)) load(pathJoin("prod_util", prod_util_ver)) -load("gsi_common") +load(pathJoin("netcdf", netcdf_ver)) +load(pathJoin("bufr", bufr_ver)) +load(pathJoin("bacio", bacio_ver)) +load(pathJoin("w3emc", w3emc_ver)) +load(pathJoin("sp", sp_ver)) +load(pathJoin("ip", ip_ver)) +load(pathJoin("sigio", sigio_ver)) +load(pathJoin("sfcio", sfcio_ver)) +load(pathJoin("nemsio", nemsio_ver)) +load(pathJoin("wrf_io", wrf_io_ver)) +load(pathJoin("ncio", ncio_ver)) +load(pathJoin("crtm", crtm_ver)) +load(pathJoin("ncdiag",ncdiag_ver)) pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230911") diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 87a21dc0f1..46d2647ac0 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -9,10 +9,15 @@ case $machine in memnode=96 numcore=40 ;; - Orion) + Orion) sub_cmd="sub_orion" memnode=192 numcore=40 + ;; + Hercules) + sub_cmd="sub_hercules" + memnode=512 + numcore=40 ;; Jet) sub_cmd="sub_jet" @@ -59,6 +64,9 @@ case $regtest in elif [[ "$machine" = "Orion" ]]; then topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" @@ -87,20 +95,23 @@ case $regtest in rrfs_3denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -117,20 +128,23 @@ case $regtest in hafs_3denvar_hybens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -146,20 +160,23 @@ case $regtest in hafs_4denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -176,20 +193,23 @@ case $regtest in netcdf_fv3_regional) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" @@ -206,20 +226,23 @@ case $regtest in rtma) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/2" @@ -236,20 +259,23 @@ case $regtest in global_enkf) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -300,7 +326,10 @@ if [[ "$machine" = "Hera" ]]; then export APRUN="srun" elif [[ "$machine" = "Orion" ]]; then export OMP_STACKSIZE=2048M - export APRUN="srun -n \$ntasks" + export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" +elif [[ "$machine" = "Hercules" ]]; then + export OMP_STACKSIZE=2048M + export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" elif [[ "$machine" = "Jet" ]]; then export OMP_STACKSIZE=1024M export MPI_BUFS_PER_PROC=256 diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 7403d89ec0..02ffb24b12 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -42,8 +42,10 @@ elif [[ -d /sw/gaea ]]; then # Gaea export machine="Gaea" elif [[ -d /data/prod ]]; then # S4 export machine="S4" -elif [[ -d /work ]]; then # Orion +elif [[ -d /work && $(hostname) =~ "Orion" ]]; then # Orion export machine="Orion" +elif [[ -d /work && $(hostname) =~ "hercules" ]]; then # Hercules + export machine="Hercules" elif [[ -d /lfs/h2 ]]; then # wcoss2 export machine="wcoss2" fi @@ -98,18 +100,25 @@ case $machine in export check_resource="no" export accnt="${accnt:-GFS-DEV}" ;; - Orion) + Orion | Hercules) export local_or_default="${local_or_default:-/work/noaa/da/$LOGNAME}" if [ -d $local_or_default ]; then - export noscrub="$local_or_default/noscrub" + export noscrub="$local_or_default/noscrub" elif [ -d /work/noaa/global/$LOGNAME ]; then - export noscrub="/work/noaa/global/$LOGNAME/noscrub" + export noscrub="/work/noaa/global/$LOGNAME/noscrub" fi export queue="${queue:-batch}" + + if [[ "${machine}" == "Orion" ]]; then + export partition="${partition:-orion}" + else + export partition="${partition:-hercules}" + fi + export group="${group:-global}" if [[ "$cmaketest" = "false" ]]; then - export basedir="/work/noaa/da/$LOGNAME/gsi" + export basedir="/work/noaa/da/$LOGNAME/gsi" fi export ptmp="${ptmp:-/work/noaa/stmp/$LOGNAME/$ptmpName}" diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index 6f0673ce29..ac6c7f58d1 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -25,6 +25,8 @@ case $(hostname -f) in Orion-login-[1-4].HPC.MsState.Edu) MACHINE_ID=orion ;; ### orion1-4 + Hercules-login-[1-4].HPC.MsState.Edu) MACHINE_ID=hercules ;; ### hercules1-4 + cheyenne[1-6].cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 cheyenne[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 chadmin[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 diff --git a/ush/module-setup.sh b/ush/module-setup.sh index ab92477a56..d13da1efa3 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -15,6 +15,13 @@ elif [[ $MACHINE_ID = hera* ]] ; then fi module purge +elif [[ $MACHINE_ID = hercules* ]] ; then + # We are on Hercules + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /apps/other/lmod/lmod/init/bash + fi + module purge + elif [[ $MACHINE_ID = orion* ]] ; then # We are on Orion if ( ! eval module help > /dev/null 2>&1 ) ; then diff --git a/ush/sub_hercules b/ush/sub_hercules new file mode 100755 index 0000000000..573378fdb6 --- /dev/null +++ b/ush/sub_hercules @@ -0,0 +1,170 @@ +#!/bin/sh --login +set -x +usage="\ +Usage: $0 [options] executable [args] + where the options are: + -a account account (default: none) + -b binding run smt binding or not (default:NO) + -d dirin initial directory (default: cwd) + -e envars copy comma-separated environment variables + -g group group name + -i append standard input to command file + -j jobname specify jobname (default: executable basename) + -m machine machine on which to run (default: current) + -n write command file to stdout rather than submitting it + -o output specify output file (default: jobname.out) + -p procs[/nodes[/ppreq] + number of MPI tasks and optional nodes or Bblocking and + ppreq option (N or S) (defaults: serial, Bunlimited, S) + -q queue[/qpreq] queue name and optional requirement, e.g. dev/P + (defaults: 1 if serial or dev if parallel and none) + (queue 3 or 4 is dev or prod with twice tasks over ip) + (options: P=parallel, B=bigmem, b=batch) + -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) + -t timew wall time limit in [[hh:]mm:]ss format (default: 900) + -u userid userid to run under (default: self) + -v verbose mode + -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or + Thh[mm] (full, incremental, today or tomorrow) format + (default: now) +Function: This command submits a job to the batch queue." +subcmd="$*" +stdin=NO +nosub=NO +account="" +binding="NO" +dirin="" +envars="" +group="" +jobname="" +machine="" +output="" +procs=0 +nodes="" +ppreq="" +queue="" +qpreq="" +rmem="1024" +rcpu="1" +timew="900" +userid="" +verbose=NO +when="" +while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do + case $opt in + a) account="$OPTARG";; + b) binding="$OPTARG";; + d) dirin="$OPTARG";; + e) envars="$OPTARG";; + g) group="$OPTARG";; + i) stdin=YES;; + j) jobname=$OPTARG;; + m) machine="$OPTARG";; + n) nosub=YES;; + o) output=$OPTARG;; + p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; + q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; + r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; + t) timew=$OPTARG;; + u) userid=$OPTARG;; + v) verbose=YES;; + w) when=$OPTARG;; + \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; + esac +done +shift $(($OPTIND-1)) +if [[ $# -eq 0 ]];then + echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 +fi +exec=$1 +if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then + exec=$(which $exec) +fi +shift +args="$*" +bn=$(basename $exec) +export jobname=${jobname:-$bn} +output=${output:-$jobname.out} +myuser=$LOGNAME +myhost=$(hostname) +exp=${jobname} + +DATA=${ptmp:-/work/noaa/da/stmp/$LOGNAME/tmp} +mkdir -p $DATA + +#partition=${partition:-c1ms} +queue=${queue:-batch} +timew=${timew:-01:20:00} +task_node=${task_node:-$procs} +size=$((nodes*task_node)) +envars=$envars +threads=${rcpu:-1} + +export TZ=GMT +cfile=$DATA/sub$$ +> $cfile +#echo "#PBS -S /bin/sh" >> $cfile +echo "#!/bin/sh --login" >> $cfile +echo "" >> $cfile +echo "#SBATCH --output=$output" >> $cfile +echo "#SBATCH --job-name=$jobname" >> $cfile +echo "#SBATCH --qos=$queue" >> $cfile +echo "#SBATCH --partition=$partition" >> $cfile +echo "#SBATCH --time=$timew" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --account=$accnt" >> $cfile + +echo "" >>$cfile +echo "export ntasks=$(( $nodes * $procs ))" >> $cfile +echo "export ppn=$procs" >> $cfile +echo "export threads=$threads" >> $cfile +echo "export OMP_NUM_THREADS=$threads" >> $cfile +##echo "export OMP_STACKSIZE=2048M" >> $cfile +echo "ulimit -s unlimited" >> $cfile + +echo "" >>$cfile +echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile +echo "" >>$cfile + +echo ". /apps/other/lmod/lmod/init/sh" >> $cfile +echo "module purge" >> $cfile +echo "module use $modulefiles" >> $cfile +echo "module load gsi_hercules" >> $cfile +echo "module list" >> $cfile +echo "" >> $cfile +cat $exec >> $cfile + +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi + + +if [[ $stdin = YES ]];then + cat +fi >>$cfile +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +sbatch=${sbatch:-sbatch} + +ofile=$DATA/subout$$ +>$ofile +chmod 777 $ofile +$sbatch --export=ALL $cfile >$ofile +rc=$? +cat $ofile +if [[ -w $SUBLOG ]];then + jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) + date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG +fi +rm $cfile $ofile +[[ $MKDATA = YES ]] && rmdir $DATA +exit $rc diff --git a/ush/sub_orion b/ush/sub_orion index 1bcce5cc4f..e5844474db 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -87,6 +87,7 @@ export jobname=${jobname:-$bn} output=${output:-$jobname.out} myuser=$LOGNAME myhost=$(hostname) +exp=${jobname} DATA=${ptmp:-/work/noaa/da/stmp/$LOGNAME/tmp} mkdir -p $DATA @@ -108,6 +109,7 @@ echo "" echo "#SBATCH --output=$output" >> $cfile echo "#SBATCH --job-name=$jobname" >> $cfile echo "#SBATCH --qos=$queue" >> $cfile +echo "#SBATCH --partition=$partition" >> $cfile echo "#SBATCH --time=$timew" >> $cfile echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile From ea667d9995a63e50bdf67de6ac630ef587e34e1b Mon Sep 17 00:00:00 2001 From: James Jung Date: Mon, 4 Dec 2023 12:38:26 -0500 Subject: [PATCH 2/4] Cads for andrew (#616) --- src/gsi/cads.f90 | 2230 ++++++++++++++++++++++++++++++++++++ src/gsi/crtm_interface.f90 | 18 +- src/gsi/gsi_files.cmake | 1 + src/gsi/gsimod.F90 | 55 +- src/gsi/qcmod.f90 | 418 +++++-- src/gsi/read_airs.f90 | 1 - src/gsi/read_cris.f90 | 214 +++- src/gsi/read_iasi.f90 | 165 ++- src/gsi/setupaod.f90 | 3 +- src/gsi/setuprad.f90 | 71 +- 10 files changed, 2980 insertions(+), 196 deletions(-) create mode 100644 src/gsi/cads.f90 diff --git a/src/gsi/cads.f90 b/src/gsi/cads.f90 new file mode 100644 index 0000000000..6d7e584ef1 --- /dev/null +++ b/src/gsi/cads.f90 @@ -0,0 +1,2230 @@ +module cads +!$$$ module documentation block +! +! module: cads +! prgmmr: Jung +! +! abstract: module containing subroutines for the cloud and aerosol detection software +! +! program history log: +! +! +! +! subroutines included: +! +! +! remarks: variable definitions +! +! +!$$$ end documentation block + + + use kinds, only: i_kind, r_kind + implicit none + save + +! set default to private + private +! set routines to public + public :: cloud_aerosol_detection + public :: cads_setup_cloud + public :: Cloud_Detect_Type + public :: cads_imager_calc + + public :: M__Sensor,N__Num_Bands,N__GradChkInterval,N__Band_Size,N__Bands,N__Window_Width, & + N__Window_Bounds,R__BT_Threshold,R__Grad_Threshold,R__Window_Grad_Threshold, L__Do_Quick_Exit, & + L__Do_CrossBand, N__BandToUse,L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, & + N__Num_Imager_Clusters,N__Imager_Chans,R__Stddev_Threshold,R__Coverage_Threshold, & + R__FG_Departure_Threshold + + INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor + INTEGER(i_kind) :: N__Num_Bands ! Number of channel bands + INTEGER(i_kind), POINTER :: N__GradChkInterval(:) ! Window width used in gradient calculation + INTEGER(i_kind), POINTER :: N__Band_Size(:) ! Number of channels in each band + INTEGER(i_kind), POINTER :: N__Bands(:,:) ! Channel lists + INTEGER(i_kind), POINTER :: N__Window_Width(:) ! Smoothing filter window widths per band + INTEGER(i_kind), POINTER :: N__Window_Bounds(:,:) ! Channels in the spectral window gradient check + INTEGER(i_kind), POINTER :: N__BandToUse(:) ! Band number assignment for each channel + LOGICAL :: L__Do_Quick_Exit ! On/off switch for the Quick Exit scenario + LOGICAL :: L__Do_CrossBand ! On/off switch for the cross-band method + REAL(r_kind), POINTER :: R__BT_Threshold(:) ! BT threshold for cloud contamination + REAL(r_kind), POINTER :: R__Grad_Threshold(:) ! Gradient threshold for cloud contamination + REAL(r_kind), POINTER :: R__Window_Grad_Threshold(:) ! Threshold for window gradient check in QE + + LOGICAL :: L__Do_Imager_Cloud_Detection ! On/off switch for the imager cloud detection + INTEGER(i_kind) :: N__Num_Imager_Chans ! No. of imager channels + INTEGER(i_kind) :: N__Num_Imager_Clusters ! No. of clusters to be expected + INTEGER(i_kind),POINTER :: N__Imager_Chans(:) ! List of imager channels + REAL(r_kind),POINTER :: R__Stddev_Threshold(:) ! St. Dev. threshold, one for each imager channel + REAL(r_kind) :: R__Coverage_Threshold ! Threshold for fractional coverage of a cluster + REAL(r_kind) :: R__FG_Departure_Threshold ! Threshold for imager FG departure + + +! set passed variables to public + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Module * +! A. Collard ECMWF 01/02/06 + +! * PURPOSE * +! ----------- +! Sets up structures to be used in processing of advanced IR sounders. + +! * MODIFICATIONS * +! ----------------- +! 01/02/06 A.Collard 1.0 Original export version. +! 17/11/09 R.Eresmaa 1.1 Include parameters of the Quick Exit / +! long-wave window gradient check. +! 11/11/11 R.Eresmaa 1.2 Add processing capability for CrIS. +! 03/12/13 R.Eresmaa 2.0 Add imager-assisted cloud detection. +! 10/11/15 R.Eresmaa 2.2 Changed instrument ID naming convention. +! Changed aerosol detection parameters. +! 20/12/16 R.Eresmaa 2.3 Remove aerosol detection parameters. +! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! 16/04/20 R.Eresmaa 3.0 Combine cloud and aerosol detection, rename. +! Include aerosol type recognition. +! Include land sensitivity parameters. +! Include trace gas detection. Rename. + + + INTEGER(i_kind), PARAMETER :: INST_ID_AIRS = 11 + INTEGER(i_kind), PARAMETER :: INST_ID_IASI = 16 + INTEGER(i_kind), PARAMETER :: INST_ID_CRIS = 27 + INTEGER(i_kind), PARAMETER :: INST_ID_IRS = 57 + INTEGER(i_kind), PARAMETER :: INST_ID_IASING = 59 + INTEGER(i_kind), PARAMETER :: INST_ID_IKFS2 = 94 + INTEGER(i_kind), PARAMETER :: INST_ID_HIRAS = 97 + INTEGER(i_kind), PARAMETER :: INST_ID_GIIRS = 98 + + INTEGER(i_kind), PARAMETER :: JP__MIN_SENSOR_INDEX = INST_ID_AIRS + INTEGER(i_kind), PARAMETER :: JP__MAX_SENSOR_INDEX = INST_ID_GIIRS + + TYPE Aerosol_Detect_Type + INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor + INTEGER(i_kind) :: N__Num_Aerosol_Tests ! Number of aerosol detection tests + INTEGER(i_kind), POINTER :: N__Num_Regression(:) ! Number of conversion coefficients for AOD + INTEGER(i_kind), POINTER :: N__Num_Aerosol_Chans(:) ! Number of aerosol detection channels + INTEGER(i_kind), POINTER :: N__Aerosol_Chans(:,:) ! List of aerosol detection channels + INTEGER(i_kind) :: N__Mean_Aerosol_Chans ! Boxcar averaging window width + REAL(r_kind), POINTER :: R__Aerosol_TBD(:,:) ! Aerosol detection thresholds + REAL(r_kind), POINTER :: R__coef_AOD(:,:) ! Coefficients for conversion to AOD + REAL(r_kind) :: R__Rank_Thres_Coeff(3) ! Coefficients to restrict rejections to affected channels + REAL(r_kind) :: R__Unclassified_Thres ! Rejection threshold for unclassified aerosol + REAL(r_kind) :: R__Land_Fraction_Thres ! Threshold for land fraction in FOV + END TYPE Aerosol_Detect_Type + + TYPE Cloud_Detect_Type + INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor + INTEGER(i_kind) :: N__Num_Bands ! Number of channel bands + INTEGER(i_kind), POINTER :: N__GradChkInterval(:) ! Window width used in gradient calculation + INTEGER(i_kind), POINTER :: N__Band_Size(:) ! Number of channels in each band + INTEGER(i_kind), POINTER :: N__Bands(:,:) ! Channel lists + INTEGER(i_kind), POINTER :: N__Window_Width(:) ! Smoothing filter window widths per band + INTEGER(i_kind), POINTER :: N__Window_Bounds(:,:) ! Channels in the spectral window gradient check + INTEGER(i_kind), POINTER :: N__BandToUse(:) ! Band number assignment for each channel + LOGICAL :: L__Do_Quick_Exit ! On/off switch for the Quick Exit scenario + LOGICAL :: L__Do_CrossBand ! On/off switch for the cross-band method + REAL(r_kind), POINTER :: R__BT_Threshold(:) ! BT threshold for cloud contamination + REAL(r_kind), POINTER :: R__Grad_Threshold(:) ! Gradient threshold for cloud contamination + REAL(r_kind), POINTER :: R__Window_Grad_Threshold(:) ! Threshold for window gradient check in QE + + LOGICAL :: L__Do_Imager_Cloud_Detection ! On/off switch for the imager cloud detection + INTEGER(i_kind) :: N__Num_Imager_Chans ! No. of imager channels + INTEGER(i_kind) :: N__Num_Imager_Clusters ! No. of clusters to be expected + INTEGER(i_kind),POINTER :: N__Imager_Chans(:) ! List of imager channels + REAL(r_kind),POINTER :: R__Stddev_Threshold(:) ! St. Dev. threshold, one for each imager channel + REAL(r_kind) :: R__Coverage_Threshold ! Threshold for fractional coverage of a cluster + REAL(r_kind) :: R__FG_Departure_Threshold ! Threshold for imager FG departure + END TYPE Cloud_Detect_Type + + TYPE Land_Sensitivity_Type + INTEGER(r_kind) :: M__Sensor ! Unique ID for sensor + REAL(r_kind) :: R__Land_Fraction_Thres ! Threshold on land fraction + REAl(r_kind) :: R__Level_Thres ! Threshold on normalized channel height assignment + END TYPE Land_Sensitivity_Type + + TYPE Trace_Gas_Detect_Type + INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor + INTEGER(i_kind) :: N__Num_Trace_Gas_Checks ! Number of trace gases to be checked + INTEGER(i_kind),POINTER :: N__Num_Tracer_Channels(:) ! Number of gas-sensitive channels + INTEGER(i_kind),POINTER :: N__Tracer_Channels(:,:) ! Gas-sensitive channels + INTEGER(i_kind),POINTER :: N__Num_Control_Channels(:) ! Number of control channels + INTEGER(i_kind),POINTER :: N__Control_Channels(:,:) ! Control channels + INTEGER(i_kind),POINTER :: N__Num_Flagged_Channels(:) ! Number of affected channels + INTEGER(i_kind),POINTER :: N__Flagged_Channels(:,:) ! Affected channels + REAL(r_kind),POINTER :: R__D_Obs_Threshold(:) ! Observed Tb difference threshold + REAL(r_kind),POINTER :: R__D_Dep_Threshold(:) ! Departure difference threshold + END TYPE Trace_Gas_Detect_Type + + + TYPE(Aerosol_Detect_Type) :: & + S__CADS_Setup_Aerosol(JP__Min_Sensor_Index:JP__Max_Sensor_Index) + + TYPE(Cloud_Detect_Type) :: & + S__CADS_Setup_Cloud(JP__Min_Sensor_Index:JP__Max_Sensor_Index) + + TYPE(Land_Sensitivity_Type) :: & + S__CADS_Setup_Land(JP__Min_Sensor_Index:JP__Max_Sensor_Index) + + TYPE(Trace_Gas_Detect_Type) :: & + S__CADS_Setup_Trace_Gas(JP__Min_Sensor_Index:JP__Max_Sensor_Index) + + +contains + +SUBROUTINE CADS_Abort(String) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! *CADS_Abort* +! R. Eresmaa ECMWF 16/04/20 + +! * PURPOSE * +! ----------- +! Controlled abortion of running CADS when facing exceptions such as +! necessary input files missing or they are corrupt. + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Abort()* from +! CADS_Main, CADS_Setup_Aerosol, CADS_Setup_Cloud, +! CADS_Setup_Land_Sensitivity, or CADS_Setup_Trace_Gas. + + IMPLICIT NONE + CHARACTER(LEN=*) :: String + + WRITE(*,*) String + STOP + +END SUBROUTINE CADS_Abort + +subroutine cloud_aerosol_detection( I__Sensor_ID, I__Num_Chans, I__Chan_ID, & + I__Min_Level, I__Max_Level, Z__BT_Obser, Z__BT_Model, Z__Chan_Height, K__Chan_ID_Imager, & + Z__Cluster_Fraction, Z__BT_in_Cluster, Z__BT_Overall_SDev, Z__BT_Model_Imager, & + I__Flag_Cloud, Z__Cloud_Level ) + +!$$$ subprogram documentation block +! . . . +! subprogram: cloud_aerosol_detection determine clear/cloudy profiles from hyperspectral IR instruments +! +! prgmmr: jung org: cimss date: 2022-10-17 +! +! abstract: determine if a profile is clear/cloudy. If cloudy, determine which channels are affected +! This subroutine is designed for infrared hyperspectral sounders. Current code supports AIRS, IASI and CrIS.a +! This subroutine is based on the Cloud and Aerosol Detection Software Version 3 developed within the context +! of the EUMETSAT and Met Office, UK, by one or more partners within the Numerical Weather Predicion's +! Satellite Application Facilities. A version of this code is operational at ECMWF. +! COPYRIGHT 2020, EUMETSAT, ALL RIGHTS RESERVED. +! +! program history log: +! 2022-10-17 jung Initial coding +! +! input argument list: +! I_Sensor_ID - internal sensor identification. +! I__Num_Chans - number of channels per obs +! I__Chan_ID - array of actual channel numbers +! Z__Longitude - FOV longitude +! Z__Latitude - FOV latitude +! Z__Land_Fraction - FOV land fraction +! I__Min_Level - model tropopause height (start of cloud detection) +! I__Max_Level - model top of boundary layer ( stop of cloud detection) +! Z__BT_Obser - observaton brightness temperature +! Z__BT_Model - model derived brightness temperature +! Z__Chan_Height - model derived height where an opaque cloud influences the radiance. +! also used to re-organize channels +! Z__Cloud_Level - Cloud height assignment +! +! output argument list: +! icloud_layer - model layer where cloud is detected +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: i_kind, r_kind + implicit none + + integer(i_kind), intent(in ) :: I__Sensor_ID + integer(i_kind), intent(in ) :: I__Num_Chans + integer(i_kind),dimension(I__Num_Chans),intent(in ) :: I__Chan_ID + integer(i_kind), intent(in ) :: I__Min_Level !tropopause pressure + integer(i_kind), intent(in ) :: I__Max_Level !boundary layer pressure + real(r_kind), intent(in ) :: Z__BT_Obser(:) !Observation BT + real(r_kind), intent(in ) :: Z__BT_Model(:) !Model derived BT + real(r_kind), intent(in ) :: Z__Chan_Height(:) !Channel height assignmenta + integer(i_kind), intent(in ) :: K__Chan_ID_Imager(:) ! imager channel numbers + real(r_kind), intent(in ) :: Z__Cluster_Fraction(:) + real(r_kind), intent(in ) :: Z__BT_in_Cluster(:,:) + real(r_kind), intent(in ) :: Z__BT_Overall_SDev(:) + real(r_kind), intent(in ) :: Z__BT_Model_Imager(:) + real(r_kind), intent( out) :: Z__Cloud_Level ! cloud height assignment + integer(i_kind),dimension(I__Num_Chans),intent( out) :: I__Flag_Cloud ! cloud use flag + +! Interim prodcts + +! Diagnostics: percentages of positive detections +! Input/Output file management + + N__Num_Imager_Chans = S__CADS_Setup_Cloud(I__Sensor_ID) % N__Num_Imager_Chans + N__Num_Imager_Clusters = S__CADS_Setup_Cloud(I__Sensor_ID) % N__Num_Imager_Clusters + + CALL CADS_Detect_Cloud( I__Sensor_ID, I__Num_Chans, I__Chan_ID,I__Min_Level, I__Max_Level, N__Num_Imager_Chans, & + K__Chan_ID_Imager, N__Num_Imager_Clusters, I__Flag_Cloud, Z__BT_Obser, Z__BT_Model, Z__Chan_Height, & + Z__Cluster_Fraction, Z__BT_in_Cluster, Z__BT_Overall_SDev, Z__BT_Model_Imager, Z__Cloud_Level ) + +end subroutine cloud_aerosol_detection + +SUBROUTINE CADS_Setup_Cloud + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and Meteo France. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + + +! * Cloud detection setup * +! A. Collard ECMWF 01/02/06 + +! * PURPOSE * +! ----------- +! Initialise cloud detection parameters for advanced infrared sounders. + +! * INTERFACE * +! ------------- +! CADS_Setup_Cloud is called from CADS_Main. + +! * METHOD * +! ---------- +! Default values are assigned to the cloud detections setup structure. + +! MODIFICATIONS +! ------------- +! 01/02/06 A.Collard 1.0 Original code. +! 19/10/06 A.Collard 1.1 Use IASI 300 Subset Channels. +! 17/11/09 R.Eresmaa 1.2 Use IASI 366 Subset Channels. +! Include parameters of the Quick Exit / +! long-wave window gradient check parameters. +! 11/11/11 R.Eresmaa 1.3 Default channel list for AIRS bands 3-5 +! modified. +! Processing capability for CrIS added +! assuming a selection of 320 channels. +! 03/12/13 R,Eresmaa 2.0 Imager-assisted cloud detection added for +! IASI. +! Updated setup for CrIS. +! 19/01/15 R.Eresmaa 2.1 Remove unused variable specifications and +! switch aerosol detection on by default for +! AIRS and IASI. +! 10/11/15 R.Eresmaa 2.2 Changed instrument ID naming convention. +! Changed parameters of aerosol detection. +! 20/12/16 R.Eresmaa 2.3 Remove settings for aerosol detection. +! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! Add HIRAS, GIIRS (IASING + IRS added earlier) +! 16/04/20 R.Eresmaa 3.0 Rename, tidy up. + + use kinds, only: i_kind, r_kind + use gsi_io, only: verbose + IMPLICIT NONE + +! Local variables + + CHARACTER(LEN=6) :: CL__InstrumentName + CHARACTER(LEN=20) :: CL__Cloud_Detection_File + + INTEGER(i_kind) :: J, J__Sensor ! Loop variables + INTEGER(i_kind) :: INIU1, IOS + +!----------------------- +! Namelist variables +!----------------------- + +! N.B. Max_Bands must be greater than 5 + INTEGER(i_kind), PARAMETER :: JP__Max_Bands = 8 + INTEGER(i_kind), PARAMETER :: JP__Max_Channels = 8461 + + INTEGER(i_kind) :: M__Sensor + INTEGER(i_kind) :: N__Num_Bands + INTEGER(i_kind) :: N__GradChkInterval(JP__Max_Bands) + INTEGER(i_kind) :: N__Band_Size(JP__Max_Bands) + INTEGER(i_kind) :: N__Bands(JP__Max_Channels,JP__Max_Bands) + INTEGER(i_kind) :: N__Window_Width(JP__Max_Bands) + INTEGER(i_kind) :: N__Window_Bounds(JP__Max_Bands,2) + REAL(r_kind) :: R__BT_Threshold(JP__Max_Bands) + REAL(r_kind) :: R__Grad_Threshold(JP__Max_Bands) + REAL(r_kind) :: R__Window_Grad_Threshold(JP__Max_Bands) + LOGICAL :: L__Do_Quick_Exit + LOGICAL :: L__Do_CrossBand + INTEGER(i_kind) :: N__BandToUse(JP__Max_Bands) + +! Imager-based cloud detection + LOGICAL :: L__Do_Imager_Cloud_Detection + INTEGER(i_kind) :: N__Num_Imager_Chans + INTEGER(i_kind) :: N__Num_Imager_Clusters + INTEGER(i_kind) :: N__Imager_Chans(JP__Max_Bands) + REAL(r_kind) :: R__Stddev_Threshold(JP__Max_Bands) + REAL(r_kind) :: R__Coverage_Threshold + REAL(r_kind) :: R__FG_Departure_Threshold + +! Namelist + NAMELIST / Cloud_Detect_Coeffs / M__Sensor, N__Num_Bands, & + N__Band_Size, N__Bands, N__Window_Width, N__Window_Bounds, & + N__GradChkInterval, R__BT_Threshold, R__Grad_Threshold, & + R__Window_Grad_Threshold, L__Do_Quick_Exit, & + L__Do_CrossBand, N__BandToUse, & + L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, & + N__Num_Imager_Clusters, N__Imager_Chans, & + R__Stddev_Threshold, R__Coverage_Threshold, & + R__FG_Departure_Threshold + +!============================================================================ +! Loop through sensors setting up cloud detection +!============================================================================ + + SensorLoop : DO J__Sensor = JP__Min_Sensor_Index, JP__Max_Sensor_Index + +! SELECT CASE (I__Sensor_ID) + SELECT CASE (J__Sensor) + + CASE(INST_ID_AIRS) + !==================== + ! Set up AIRS + !==================== + + CL__InstrumentName='AIRS' + CL__Cloud_Detection_File = 'AIRS_CLDDET.NL' + + N__Num_Bands = 5 + + N__Band_Size(:) = 0 + N__Band_Size(1:N__Num_Bands) =(/138, 36, 54, 23, 65 /) + + N__Bands(:,:)= 0 + + N__Bands(1:N__Band_Size(1),1) = & + (/ 1, 6, 7, 10, 11, 15, 16, 17, 20, 21, & + 22, 24, 27, 28, 30, 36, 39, 40, 42, 51, & + 52, 54, 55, 56, 59, 62, 63, 68, 69, 71, & + 72, 73, 74, 75, 76, 77, 78, 79, 80, 82, & + 83, 84, 86, 92, 93, 98, 99, 101, 104, 105, & + 108, 110, 111, 113, 116, 117, 123, 124, 128, 129, & + 138, 139, 144, 145, 150, 151, 156, 157, 159, 162, & + 165, 168, 169, 170, 172, 173, 174, 175, 177, 179, & + 180, 182, 185, 186, 190, 192, 193, 198, 201, 204, & + 207, 210, 213, 215, 216, 218, 221, 224, 226, 227, & + 232, 239, 248, 250, 251, 252, 253, 256, 257, 261, & + 262, 267, 272, 295, 299, 305, 308, 309, 310, & + 318, 321, 333, 338, 355, 362, 375, 475, & + 484, 497, 528, 587, 672, 787, 791, 843, 870, 914, & + 950 /) + + N__Bands(1:N__Band_Size(2),2) = & + (/ 1003, 1012, 1019, 1024, 1030, 1038, 1048, 1069, 1079, 1082, & + 1083, 1088, 1090, 1092, 1095, 1104, 1111, 1115, 1116, 1119, & + 1120, 1123, 1130, 1138, 1142, 1178, 1199, 1206, 1221, 1237, & + 1252, 1260, 1263, 1266, 1278, 1285 /) + + N__Bands(1:N__Band_Size(3),3) = & + (/ 1290, 1301, 1304, 1329, 1371, 1382, 1415, 1424, 1449, 1455, & + 1466, 1471, 1477, 1479, 1488, 1500, 1519, 1520, 1538, 1545, & + 1565, 1574, 1583, 1593, 1614, 1627, 1636, 1644, 1652, 1669, & + 1674, 1681, 1694, 1708, 1717, 1723, 1740, 1748, 1751, 1756, & + 1763, 1766, 1771, 1777, 1780, 1783, 1794, 1800, 1803, 1806, & + 1812, 1826, 1843, 1852 /) + + N__Bands(1:N__Band_Size(4),4) = & + (/ 1865, 1866, 1867, 1868, 1869, 1872, 1873, 1875, 1876, 1877, & + 1881, 1882, 1883, 1884, 1897, 1901, 1911, 1917, 1918, 1921, & + 1923, 1924, 1928 /) + + N__Bands(1:N__Band_Size(5),5) = & + (/ 1937, 1938, 1939, 1941, 1946, 1947, 1948, 1958, 1971, 1973, & + 1988, 1995, 2084, 2085, 2097, 2098, 2099, 2100, 2101, 2103, & + 2104, 2106, 2107, 2108, 2109, 2110, 2111, 2112, 2113, 2114, & + 2115, 2116, 2117, 2118, 2119, 2120, 2121, 2122, 2123, 2128, & + 2134, 2141, 2145, 2149, 2153, 2164, 2189, 2197, 2209, 2226, & + 2234, 2280, 2318, 2321, 2325, 2328, 2333, 2339, 2348, 2353, & + 2355, 2363, 2370, 2371, 2377 /) + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/ 5,5,5,5,5 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 14,6,8,5,8 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 475 + N__Window_Bounds(1,2) = 950 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.43_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind/) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,4,1 /) + + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .FALSE. + + N__Num_Imager_Chans = 0 + N__Num_Imager_Clusters = 0 + N__Imager_Chans(:) = 0 + + R__Stddev_Threshold(:) = 0.0_r_kind + R__Coverage_Threshold = 0.0_r_kind + R__FG_Departure_Threshold = 0.0_r_kind + + + CASE(INST_ID_IASI) + !==================== + ! Set up IASI + !==================== + + CL__InstrumentName='IASI' + CL__Cloud_Detection_File = 'IASI_CLDDET.NL' + + N__Num_Bands = 5 + + N__Band_Size(:) = 0 + N__Band_Size(1:N__Num_Bands) =(/ 184, 15, 116, 4, 15 /) + + N__Bands(:,:)= 0 + + ! Use the "IASI 366" Subset + N__Bands(1:N__Band_Size(1),1) = & + (/ 16, 38, 49, 51, 55, 57, 59, 61, 63, 66, & + 70, 72, 74, 79, 81, 83, 85, 87, 89, 92, & + 95, 97, 99, 101, 104, 106, 109, 111, 113, 116, & + 119, 122, 125, 128, 131, 133, 135, 138, 141, 144, & + 146, 148, 151, 154, 157, 159, 161, 163, 165, 167, & + 170, 173, 176, 178, 179, 180, 183, 185, 187, 189, & + 191, 193, 195, 197, 199, 201, 203, 205, 207, 210, & + 212, 214, 217, 219, 222, 224, 226, 228, 230, 232, & + 234, 236, 239, 241, 242, 243, 246, 249, 252, 254, & + 256, 258, 260, 262, 265, 267, 269, 271, 272, 273, & + 275, 278, 280, 282, 284, 286, 288, 290, 292, 294, & + 296, 299, 301, 303, 306, 308, 310, 312, 314, 316, & + 318, 320, 323, 325, 327, 329, 331, 333, 335, 341, & + 347, 350, 352, 354, 356, 358, 360, 362, 364, 366, & + 369, 371, 373, 375, 377, 379, 381, 386, 389, 404, & + 407, 410, 414, 416, 426, 428, 432, 434, 445, 457, & + 515, 546, 552, 566, 571, 573, 646, 662, 668, 756, & + 867, 921, 1027, 1090, 1133, 1191, 1194, 1271, 1805, 1884, & + 1946, 1991, 2094, 2239 /) + + N__Bands(1:N__Band_Size(2),2) = & + (/ 1479, 1509, 1513, 1521, 1536, 1574, 1579, 1585, 1587, 1626, & + 1639, 1643, 1652, 1658, 1671 /) + + N__Bands(1:N__Band_Size(3),3) = & + (/ 2119, 2213, 2271, 2321, 2398, 2701, 2741, 2819, 2889, 2907, & + 2910, 2919, 2939, 2944, 2948, 2951, 2958, 2977, 2985, 2988, & + 2991, 2993, 3002, 3008, 3014, 3027, 3029, 3036, 3047, 3049, & + 3053, 3058, 3064, 3069, 3087, 3093, 3098, 3105, 3107, 3110, & + 3127, 3136, 3151, 3160, 3165, 3168, 3175, 3178, 3207, 3228, & + 3244, 3248, 3252, 3256, 3263, 3281, 3303, 3309, 3312, 3322, & + 3375, 3378, 3411, 3438, 3440, 3442, 3444, 3446, 3448, 3450, & + 3452, 3454, 3458, 3467, 3476, 3484, 3491, 3497, 3499, 3504, & + 3506, 3509, 3518, 3527, 3555, 3575, 3577, 3580, 3582, 3586, & + 3589, 3599, 3653, 3658, 3661, 4032, 5368, 5371, 5379, 5381, & + 5383, 5397, 5399, 5401, 5403, 5405, 5455, 5480, 5483, 5485, & + 5492, 5502, 5507, 5509, 5517, 5558 /) + + N__Bands(1:N__Band_Size(4),4) = & + (/ 5988, 5992, 5994, 6003 /) + + N__Bands(1:N__Band_Size(5),5) = & + (/ 6982, 6985, 6987, 6989, 6991, 6993, 6995, 6997, 7267, 7269, & + 7424, 7426, 7428, 7885, 8007 /) + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/12,5,5,5,5 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 10,6,8,5,8 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 573 + N__Window_Bounds(1,2) = 2239 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind /) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,1,1 /) + + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .TRUE. + + N__Num_Imager_Chans = 2 + N__Num_Imager_Clusters = 7 + + N__Imager_Chans(1:N__Num_Imager_Chans) = (/ 2, 3 /) + + R__Stddev_Threshold(1:N__Num_Imager_Chans) = (/ 0.75_r_kind, 0.80_r_kind /) + + R__Coverage_Threshold = 0.03_r_kind + R__FG_Departure_Threshold = 1.0_r_kind + + + CASE(INST_ID_CRIS) + !==================== + ! Set up CRIS + !==================== + + CL__InstrumentName='CRIS' + CL__Cloud_Detection_File = 'CRIS_CLDDET.NL' + + N__Num_Bands = 5 + + N__Band_Size(:) = 0 + + N__Band_Size(1:N__Num_Bands) =(/ 137, 123, 76, 12, 6 /) + + N__Bands(:,:)= 0 + + ! Use the "CRIS 300" Subset + N__Bands(1:N__Band_Size(1),1) = & + (/ 1, 5, 9, 13, 17, 18, 19, 20, 21, 22, & + 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, & + 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, & + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, & + 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, & + 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, & + 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, & + 83, 84, 85, 86, 87, 88, 91, 92, 93, 94, & + 95, 96, 97, 99, 101, 105, 107, 109, 111, 113, & + 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, & + 125, 133, 135, 137, 139, 141, 144, 147, 161, 173, & + 177, 181, 185, 195, 210, 221, 225, 229, 249, 257, & + 269, 273, 293, 301, 317, 333, 349, 369, 409, 433, & + 457, 481, 501, 549, 701, 705, 709 /) + + N__Bands(1:N__Band_Size(2),2) = & + (/ 3, 6, 7, 8, 10, 12, 14, 15, 16, 89, & + 90, 102, 103, 104, 106, 108, 110, 114, 126, 127, & + 129, 132, 134, 138, 140, 143, 145, 146, 148, 149, & + 150, 151, 153, 155, 156, 157, 158, 159, 162, 163, & + 164, 165, 166, 169, 170, 171, 172, 175, 180, 189, & + 200, 201, 205, 206, 214, 217, 218, 226, 228, 230, & + 231, 233, 236, 237, 240, 241, 245, 248, 252, 264, & + 265, 281, 285, 297, 324, 327, 361, 378, 389, 392, & + 400, 473, 493, 500, 503, 511, 527, 528, 529, 530, & + 531, 534, 538, 542, 544, 545, 547, 550, 553, 555, & + 590, 594, 598, 602, 606, 610, 614, 618, 622, 626, & + 645, 649, 653, 657, 661, 665, 685, 702, 703, 704, & + 706, 707, 713 /) + + N__Bands(1:N__Band_Size(3),3) = & + (/ 717, 725, 728, 729, 730, 731, 732, 733, 734, 735, & + 736, 741, 749, 757, 765, 773, 781, 789, 794, 797, & + 805, 806, 815, 822, 829, 839, 845, 853, 861, 868, & + 869, 872, 877, 885, 887, 893, 898, 900, 909, 912, & + 915, 917, 921, 929, 933, 941, 949, 957, 963, 965, & + 973, 975, 978, 981, 989, 991, 993, 996, 1005, 1014, & + 1025, 1029, 1037, 1042, 1053, 1061, 1073, 1077, 1085, 1093, & + 1101, 1109, 1117, 1125, 1133, 1141 /) + + N__Bands(1:N__Band_Size(4),4) = & + (/ 1149, 1157, 1164, 1165, 1173, 1181, 1189, 1197, 1205, 1213, & + 1221, 1251 /) + + N__Bands(1:N__Band_Size(5),5) = & + (/ 1189, 1197, 1205, 1213, 1221, 1251 /) + + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/ 5,5,5,3,3 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 6,6,8,3,3 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 229 + N__Window_Bounds(1,2) = 549 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind /) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,1,1 /) + + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .FALSE. + + N__Num_Imager_Chans = 0 + N__Num_Imager_Clusters = 0 + N__Imager_Chans(:) = 0 + + R__Stddev_Threshold(:) = 0.0_r_kind + R__Coverage_Threshold = 0.0_r_kind + R__FG_Departure_Threshold = 0.0_r_kind + + + CASE(INST_ID_IRS) + !==================== + ! Set up IRS + !==================== + + CL__InstrumentName='IRS' + CL__Cloud_Detection_File = 'IRS_CLDDET.NL' + + N__Num_Bands = 1 + + N__Band_Size(:) = 0 + + N__Band_Size(1:N__Num_Bands) =(/ 138 /) + + N__Bands(:,:)= 0 + + N__Bands(1:N__Band_Size(1),1) = & + (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & + 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, & + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, & + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, & + 41, 42, 43, 44, 45, 46, 48, 53, 54, 55, & + 56, 57, 58, 60, 61, 62, 63, 65, 70, 74, & + 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, & + 85, 86, 87, 89, 90, 91, 92, 93, 94, 95, & + 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, & + 106, 107, 108, 109, 118, 119, 131, 145, 163, 169, & + 177, 180, 190, 195, 199, 209, 215, 221, 231, 237, & + 252, 262, 268, 281, 289, 298, 312, 322, 328, 341, & + 347, 359, 375, 384, 390, 404, 412, 421, 648, 656, & + 667, 678, 686, 692, 709, 750, 792, 808 /) + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/ 12 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 10 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 131 + N__Window_Bounds(1,2) = 808 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.4_r_kind /) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1 /) + + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .FALSE. + + N__Num_Imager_Chans = 0 + N__Num_Imager_Clusters = 0 + N__Imager_Chans(:) = 0 + + R__Stddev_Threshold(:) = 0.0_r_kind + R__Coverage_Threshold = 0.0_r_kind + R__FG_Departure_Threshold = 0.0_r_kind + + + CASE(INST_ID_IASING) + !==================== + ! Set up IASING + !==================== + + CL__InstrumentName='IASING' + CL__Cloud_Detection_File = 'IASING_CLDDET.NL' + + N__Num_Bands = 1 + + N__Band_Size(:) = 0 + + N__Band_Size(1:N__Num_Bands) =(/ 254 /) + + N__Bands(:,:)= 0 + + N__Bands(1:N__Band_Size(1),1) = & + (/ 31, 75, 97, 101, 109, 113, 117, 121, 125, 131, & + 139, 143, 147, 157, 161, 165, 169, 173, 177, 183, & + 189, 193, 197, 201, 207, 211, 217, 221, 225, 231, & + 237, 243, 249, 255, 261, 265, 269, 275, 281, 287, & + 291, 295, 301, 307, 313, 317, 321, 325, 329, 333, & + 339, 345, 351, 355, 357, 359, 365, 369, 373, 377, & + 381, 385, 389, 393, 397, 401, 403, 405, 407, 409, & + 411, 413, 415, 417, 419, 421, 423, 425, 427, 429, & + 431, 433, 435, 437, 439, 441, 443, 445, 447, 449, & + 451, 453, 455, 457, 459, 461, 463, 465, 467, 469, & + 471, 473, 475, 477, 479, 481, 483, 485, 487, 489, & + 491, 493, 495, 497, 499, 501, 503, 505, 507, 509, & + 511, 513, 515, 517, 519, 521, 523, 525, 527, 529, & + 531, 533, 535, 537, 539, 541, 543, 545, 547, 549, & + 551, 553, 555, 557, 559, 561, 563, 565, 567, 569, & + 571, 573, 575, 577, 579, 581, 583, 585, 587, 589, & + 591, 593, 595, 597, 601, 603, 605, 607, 609, 611, & + 613, 615, 617, 619, 621, 623, 625, 627, 629, 631, & + 633, 635, 637, 639, 641, 643, 645, 647, 649, 651, & + 653, 655, 657, 659, 661, 663, 665, 667, 669, 681, & + 693, 699, 703, 707, 711, 715, 719, 723, 727, 731, & + 737, 741, 745, 749, 753, 757, 761, 771, 777, 807, & + 813, 819, 827, 831, 851, 855, 863, 867, 889, 913, & + 1029, 1091, 1103, 1131, 1141, 1145, 1291, 1323, 1335, 1511, & + 1733, 1841, 2053, 2179, 2265, 2381, 2387, 2541, 3609, 3767, & + 3891, 3981, 4187, 4477 /) + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/ 25 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 20 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 1145 + N__Window_Bounds(1,2) = 4477 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.27_r_kind /) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1 /) + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .FALSE. + + N__Num_Imager_Chans = 0 + N__Num_Imager_Clusters = 0 + N__Imager_Chans(:) = 0 + + R__Stddev_Threshold(:) = 0.0_r_kind + R__Coverage_Threshold = 0.0_r_kind + R__FG_Departure_Threshold = 0.0_r_kind + + + END SELECT + + !------------------------------------------------------------------ + ! Open and read file containing cloud detection setup for the + ! current instrument + !------------------------------------------------------------------ + + INIU1=107 + OPEN(INIU1,STATUS='OLD',FORM='FORMATTED', & + FILE=TRIM(CL__Cloud_Detection_File), IOSTAT=IOS) + IF (IOS == 0) THEN + READ(INIU1,nml=Cloud_Detect_Coeffs,IOSTAT=IOS) + IF (IOS == 0) THEN + if ( verbose ) WRITE(*,'(3X,A)') TRIM(CL__InstrumentName) // & + ' CLOUD DETECTION FILE READ OK' + ELSE + CALL CADS_Abort('PROBLEM READING '//TRIM(CL__InstrumentName)//& + 'CLOUD DETECTION FILE') + ENDIF + CLOSE(INIU1) + ELSE + if ( verbose ) WRITE(*,'(3X,A)') 'NO '//TRIM(CL__InstrumentName) // & + ' CLOUD DETECTION FILE : Using Default Values' + ENDIF + + IF (MAXVAL(N__Band_Size(:)) > JP__Max_Channels) & + CALL CADS_Abort('Too many channels specified in cloud '//& + 'detection - increase JP__Max_Channels') + + + M__Sensor = J__SENSOR + + !------------------------------------------------------------------ + ! Set up the S__CADS_Setup_Cloud structure for current sensor + !------------------------------------------------------------------ + + S__CADS_Setup_Cloud(J__SENSOR) % M__SENSOR = M__Sensor + + S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Bands = N__Num_Bands + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__Band_Size(N__Num_Bands) ) + + S__CADS_Setup_Cloud(J__SENSOR) % N__Band_Size(:) = & + N__Band_Size(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__Bands & + (MAXVAL(N__Band_Size(:)), N__Num_Bands)) + + S__CADS_Setup_Cloud(J__SENSOR) % N__Bands(:,:) = 0 + + DO J = 1, N__Num_Bands + S__CADS_Setup_Cloud(J__SENSOR) % N__Bands(1:N__Band_Size(J),J) = & + N__Bands(1:N__Band_Size(J),J) + ENDDO + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Width(N__Num_Bands) ) + + S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Width(:) = & + N__Window_Width(1:N__Num_Bands) + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % R__BT_Threshold(N__Num_Bands) ) + S__CADS_Setup_Cloud(J__SENSOR) % R__BT_Threshold(:) = & + R__BT_Threshold(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % R__Grad_Threshold(N__Num_Bands)) + S__CADS_Setup_Cloud(J__SENSOR) % R__Grad_Threshold(:) = & + R__Grad_Threshold(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % & + R__Window_Grad_Threshold(N__Num_Bands)) + + S__CADS_Setup_Cloud(J__SENSOR) % R__Window_Grad_Threshold(:) = & + R__Window_Grad_Threshold(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__GradChkInterval(N__Num_Bands)) + S__CADS_Setup_Cloud(J__SENSOR) % N__GradChkInterval(:) = & + N__GradChkInterval(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Bounds(N__Num_Bands,2)) + S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Bounds(:,:) = & + N__Window_Bounds(1:N__Num_Bands,:) + + S__CADS_Setup_Cloud(J__SENSOR) % L__Do_Quick_Exit = L__Do_Quick_Exit + + + !------------- + ! Cross Band + !------------- + + S__CADS_Setup_Cloud(J__SENSOR) % L__Do_CrossBand = L__Do_CrossBand + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__BandToUse(N__Num_Bands) ) + S__CADS_Setup_Cloud(J__SENSOR) % N__BandToUse(:) = & + N__BandToUse(1:N__Num_Bands) + + + !------------- + ! Imager cloud detection + !------------- + + S__CADS_Setup_Cloud(J__SENSOR) % L__Do_Imager_Cloud_Detection = & + L__Do_Imager_Cloud_Detection + + S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Imager_Chans = & + N__Num_Imager_Chans + + S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Imager_Clusters = & + N__Num_Imager_Clusters + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % & + N__Imager_Chans(N__Num_Imager_Chans)) + S__CADS_Setup_Cloud(J__SENSOR) % N__Imager_Chans(:) = & + N__Imager_Chans(1:N__Num_Imager_Chans) + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % & + R__Stddev_Threshold(N__Num_Imager_Chans)) + S__CADS_Setup_Cloud(J__SENSOR) % R__Stddev_Threshold(:) = & + R__Stddev_Threshold(1:N__Num_Imager_Chans) + + S__CADS_Setup_Cloud(J__SENSOR) % R__Coverage_Threshold = & + R__Coverage_Threshold + + S__CADS_Setup_Cloud(J__SENSOR) % R__FG_Departure_Threshold = & + R__FG_Departure_Threshold + + ENDDO SensorLoop + +END SUBROUTINE CADS_SETUP_CLOUD + +SUBROUTINE CADS_Detect_Cloud( K__Sensor, K__NChans, K__ChanID, K__Minlev, K__Maxlev, & + K__Num_Imager_Chans, K__Chan_ID_Imager, K__Num_Imager_Clusters, & + K__Cloud_Flag, P__ObsBTs, P__ModelBTs, P__Chan_Level, P__Cluster_Fraction,& + P__BT_in_Cluster, P__BT_Overall_SDev, P__BT_Model_Imager, Z__Cloud_Level ) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. + +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud * +! Phil Watts ECMWF 21/01/02 + +! * PURPOSE * +! ----------- +! Flag the presence or otherwise of cloud contamination in AIRS/IASI +! channels using a rank-sorted/model difference method. Currently +! only a digital filter is supported. + + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Detect_Cloud( )* (from CADS_Main) +! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS) +! K__NChans : Number of channels +! K__ChanID : Channel indices of input channels +! K__Minlev : Highest allowed starting point for the cloud search +! K__Maxlev : Lowest allowed starting point in the initial cloud search +! K__Num_Imager_Chans : Number of collocated imager channels +! K__Chan_ID_Imager : Collocated imager channel indices +! K__Num_Imager_Clusters : Number of collocated clusters +! K__Cloud_Flag : Cloud flag by channel; 0=clear, 1=cloudy +! P__ObsBTs : Potentially cloud-affected observed BTs +! P__ModelBTs : Clear background brightness temperatures (BTs) +! P__Chan_Level : Channel height assignments +! P__Cluster_Fraction : Fractional coverage of each cluster within FOV +! P__BT_in_Cluster : Cluster-mean brightness temperature (BT) on each channel +! P__BT_Overall_SDev : Overall BT standard deviation on each channel +! P__BT_Model_Imager : Forward-modelled BT on each channel +! Z__Cloud_Level : Cloud height assignment + +! * EXTERNALS * +! ------------- +! CADS_Detect_Cloud_Imager, CADS_Detect_Cloud_Heapsort, +! CADS_Detect_Cloud_Smooth, CADS_Detect_Cloud_Scenario, +! CADS_Detect_Cloud_Separator + +! * MODIFICATIONS * +! ----------------- +! A.Collard 1.0 01/02/06 Original export version +! A.Collard 1.0.1 03/05/06 Allow for missing channels +! A.Collard 1.0.2 04/05/06 Allow cross-band cloud detection +! A.Collard 1.0.3 15/01/07 Initialise with automatic cross-band for +! all channels from band 1 for IASI +! R.Eresmaa 1.1 17/11/09 Include parameters of the Quick Exit / +! long-wave window gradient check. +! Pass K__Chan_Low to CF_DIGITAL to allow +! detecting cirrus in case of compensating +! humidity bg error in PBL. +! R.Eresmaa 1.2 11/11/11 Modify the cross-band option to be based +! on the lowest clear channel rather than +! on the highest cloud-contaminated one +! R.Eresmaa 2.0 27/11/13 Add input cloud flag based on collocated +! imager data +! R.Eresmaa 2.1 13/01/15 Make array size specifications implicit. +! R.Eresmaa 2.2 10/11/15 Instrument ID naming convention made +! consistent with RTTOV. +! Changed setting of the aerosol flag. +! R.Eresmaa 2.2.1 13/11/15 Don't allow flagging missing channels clear +! through the cross-band option. +! R.Eresmaa 2.3 20/12/16 Remove the call to aerosol detection. +! R.Eresmaa 2.4 05/02/19 Explicit KIND specifications. +! R.Eresmaa 3.0 16/04/20 Move the call to imager-based detection here. + + use kinds, only: i_kind, r_kind + use gsi_io, only: verbose + IMPLICIT NONE + +!* 0.1 Global arrays + INTEGER(i_kind), INTENT(IN) :: K__Sensor ! Sensor + INTEGER(i_kind), INTENT(IN) :: K__NChans ! No. of channels + INTEGER(i_kind), INTENT(IN) :: K__ChanID(:) ! Channel IDs + INTEGER(i_kind), INTENT(IN) :: K__Minlev ! Highest starting point for cloud search + INTEGER(i_kind), INTENT(IN) :: K__Maxlev ! Lowest starting point in the initial search + INTEGER(i_kind), INTENT(IN) :: K__Num_Imager_Chans ! No. of imager channels + INTEGER(i_kind), INTENT(IN) :: K__Chan_ID_Imager(:) ! Imager channel IDs + INTEGER(i_kind), INTENT(IN) :: K__Num_Imager_Clusters ! No. of imager clusters + INTEGER(i_kind), INTENT(OUT) :: K__Cloud_Flag(:) ! Output cloud flags + REAL(r_kind), INTENT(IN) :: P__ObsBTs(:) ! Observed BTs + REAL(r_kind), INTENT(IN) :: P__ModelBTs(:) ! Model clear BTs + REAL(r_kind), INTENT(IN) :: P__Chan_Level(:) ! Channel height assignments + REAL(r_kind), INTENT(IN) :: P__Cluster_Fraction(:) ! Cluster coverages + REAL(r_kind), INTENT(IN) :: P__BT_in_Cluster(:,:) ! Mean BT in cluster / channel + REAL(r_kind), INTENT(IN) :: P__BT_Overall_Sdev(:) ! St.Dev of imager BT in FOV + REAL(r_kind), INTENT(IN) :: P__BT_Model_Imager(:) ! Model-based estimate of imager BT + REAL(r_kind), INTENT(OUT) :: Z__Cloud_Level ! Cloud hight assignment + +!* 0.2 local variables + INTEGER(i_kind) :: IST,ICOUNT,J,I_K,JBAND,JBAND2 + INTEGER(i_kind) :: I__Imager_Flag ! Preliminary cloud flag from collocated imager data + +!* 0.3 Local variables - band splitting details + INTEGER(i_kind), POINTER :: I__Bands(:,:) ! Channel bands + INTEGER(i_kind), POINTER :: I__Band_Size(:) ! Number of channels per band + INTEGER(i_kind), POINTER :: I__BandToUse(:) ! Cross-band definitions + INTEGER(i_kind) :: I__Num_Bands ! Number of bands + INTEGER(i_kind) :: I__NumFoundChans ! Number of usable channels + INTEGER(i_kind) :: I__BandNumber(K__NChans) ! Channel band indicator + INTEGER(i_kind) :: I__WindowBounds(2) ! Boundary of window + INTEGER(i_kind) :: I__Window_Chans(2) ! Boundary of long-wave window + INTEGER(i_kind), ALLOCATABLE :: I__INDEX(:) ! Channel ranking within a band + INTEGER(i_kind), ALLOCATABLE :: IDCHAN(:) ! Overall channel ranking + INTEGER(i_kind), ALLOCATABLE :: I__Cloud_Flag(:) ! Rank-sorted output cloud flags + INTEGER(i_kind) :: I__Scenario_Index ! 1--Quick Exit, 2--Warm Start, 3--Cold Start + INTEGER(i_kind) :: I__Start_Channel ! Final starting channel in the cloud search + + LOGICAL :: LL__Do_CrossBand + +! Input array projections (handling one detection band at a time) + REAL(r_kind), ALLOCATABLE :: Z__DBT(:) ! Original departures + REAL(r_kind), ALLOCATABLE :: Z__Smooth_DBT(:) ! Smoothed departures + REAL(r_kind), ALLOCATABLE :: Z__LEVEL(:) ! Channel height assignments + +!* 0.4 Local variables - digital filter parameters + INTEGER(i_kind) :: I__CHAN_HIGH ! Channel at K__Minlev + INTEGER(i_kind) :: I__CHAN_LOW ! Channel at K__Maxlev + INTEGER(i_kind) :: I__FirstCloudyChannel ! Highest cloud-affected channel + INTEGER(i_kind) :: I__LastClearChannel ! Lowest clear channel + INTEGER(i_kind),POINTER :: I__Window_Width(:) ! Box-car filter width + INTEGER(i_kind),POINTER :: I__GradChkInterval(:) ! Gradient-check interval + +!====================================================================== + + +! Get correct processing parameters for this sensor: + I__Num_Bands = S__CADS_Setup_Cloud(K__Sensor) % N__Num_Bands + I__Band_Size => S__CADS_Setup_Cloud(K__Sensor) % N__Band_Size + I__Bands => S__CADS_Setup_Cloud(K__Sensor) % N__Bands + I__Window_Width => S__CADS_Setup_Cloud(K__Sensor) % N__Window_Width + I__BandToUse => S__CADS_Setup_Cloud(K__Sensor) % N__BandToUse + LL__Do_CrossBand = S__CADS_Setup_Cloud(K__Sensor) % L__Do_CrossBand + I__GradChkInterval => S__CADS_Setup_Cloud(K__Sensor) % N__GradChkInterval + + +! Initialise + K__Cloud_Flag(:)=1 ! intialise ALL channels to cloudy + + +! Imager-based cloud detection + I__Imager_Flag=0 ! Default assumption: no cloud affecting collocated imager data + CALL CADS_Detect_Cloud_Imager( K__Sensor, K__Num_Imager_Chans, K__Chan_ID_Imager, K__Num_Imager_Clusters, & + I__Imager_Flag, P__Cluster_Fraction, P__BT_in_Cluster, P__BT_Overall_SDev, P__BT_Model_Imager ) + +! If using cross-band, set up an array indicating which channels correspond +! to which bands in K__ChanID + IF (LL__Do_CrossBand) THEN + I__BandNumber(:)=-1 ! Initialise + DO JBAND = 1, I__Num_Bands + DO I_K=1,K__NChans + IF (ANY(I__BANDS(:,JBAND) == K__ChanID(I_K))) & + I__BandNumber(I_K)=JBand + ENDDO + ENDDO + ENDIF + + +!1 Loop over bands + Band_Loop: DO JBAND = 1, I__Num_Bands + + ! Don't bother doing the cloud detection if we're just going to use + ! the results from another band anyway: + IF (LL__Do_CrossBand) THEN + IF (.NOT.(ANY(I__BandToUse(:) == JBAND))) CYCLE + ENDIF + + ALLOCATE (Z__DBT(I__Band_Size(JBAND))) + Z__DBT(:) = 0.0_r_kind + + ALLOCATE (Z__LEVEL(I__Band_Size(JBAND))) + Z__LEVEL(:) = REAL(K__Maxlev) + + ALLOCATE (I__Cloud_Flag(I__Band_Size(JBAND))) + ALLOCATE (I__INDEX(I__Band_Size(JBAND))) + + ALLOCATE (IDCHAN(I__Band_Size(JBAND))) + IDCHAN(:) = 1 + + + I__WindowBounds(:) = & + S__CADS_Setup_Cloud(K__Sensor) % N__Window_Bounds(JBand,:) + +!1.1 find channels within current band -------------------------------------- + I__NumFoundChans = 0 + I__Window_Chans(:) = -1 + + DO J=1,I__Band_Size(JBAND) + DO I_K=1,K__NChans + IF (K__ChanID(I_K) == I__BANDS(J,JBAND)) THEN +! IF (P__ObsBTs(I_K) < 0. .OR. P__ModelBTs(I_K) < 0.) CYCLE + IF (P__ObsBTs(I_K) < 60.0_r_kind .OR. P__ModelBTs(I_K) < 60.0_r_kind) CYCLE ! Missing channels are set to 50.0K + I__NumFoundChans = I__NumFoundChans + 1 + Z__DBT(I__NumFoundChans)=P__ObsBTs(I_K)-P__ModelBTs(I_K) + Z__LEVEL(I__NumFoundChans)=P__Chan_Level(I_K) + I__INDEX(I__NumFoundChans)=I__NumFoundChans + IDCHAN(I__NumFoundChans)=I_K + IF (K__ChanID(I_K) == I__WindowBounds(1)) & + I__Window_Chans(1) = I__NumFoundChans + IF (K__ChanID(I_K) == I__WindowBounds(2)) & + I__Window_Chans(2) = I__NumFoundChans + ENDIF + ENDDO + ENDDO + IF ( I__NumFoundChans == 0 ) THEN + if (verbose) WRITE(*,*) & + '**CADS_Detect_Cloud - WARNING: ' // & + 'CHANNELS NOT FOUND CYCLING BAND: **', JBAND + IF (ALLOCATED(Z__DBT)) DEALLOCATE (Z__DBT) + IF (ALLOCATED(Z__LEVEL)) DEALLOCATE (Z__LEVEL) + IF (ALLOCATED(I__Cloud_Flag)) DEALLOCATE (I__Cloud_Flag) + IF (ALLOCATED(I__INDEX)) DEALLOCATE (I__INDEX) + IF (ALLOCATED(IDCHAN)) DEALLOCATE (IDCHAN) + CYCLE Band_Loop + ENDIF + +!---------------------------------------------------------------------------- + IST=0 + ICOUNT=I__NumFoundChans + I__Cloud_Flag(:)=1 + +!2. Sort according to channel height assignments + CALL CADS_Detect_Cloud_Heapsort(I__NumFoundChans,Z__Level,I__Index) + +!2.1 Find I__CHAN_LOW - lowest channel considered in the initial cloud search + J=1 + DO WHILE (J < I__NumFoundChans .AND. Z__Level(I__Index(J)) < REAL(K__Maxlev)) + J=J+1 + ENDDO + + IF (J == I__NumFoundChans) THEN + I__CHAN_LOW = I__NumFoundChans-1 + ELSE + I__CHAN_LOW = J + ENDIF + IF(I__CHAN_LOW <= 1)I__CHAN_LOW=1 + +!2.1a Find I__CHAN_HIGH - highest allowed channel for starting the cloud search + J=1 + DO WHILE (J < I__NumFoundChans .AND. Z__Level(I__Index(J)) < REAL(K__Minlev)) + J=J+1 + ENDDO + I__CHAN_HIGH=J + + +! Smoothing + ALLOCATE (Z__Smooth_DBT(I__NumFoundChans)) + Z__Smooth_DBT(:) = 0.0_r_kind + + CALL CADS_Detect_Cloud_Smooth( I__NumFoundChans, I__Window_Width(JBAND), Z__DBT(I__INDEX(1:I__NumFoundChans)), & + Z__Smooth_DBT(1:I__NumFoundChans) ) + + +!3. Choice of cloud detection scenario + + CALL CADS_Detect_Cloud_Scenario( K__Sensor, JBAND, I__NumFoundChans, I__GradChkInterval(JBAND), I__Index(1:I__NumFoundChans), & + I__CHAN_HIGH, I__CHAN_LOW, I__Window_Chans, I__Imager_Flag, I__Scenario_Index, I__Start_Channel, Z__Smooth_DBT(1:I__NumFoundChans)) + + +!4. Identify the separation between clear/cloudy channels + + CALL CADS_Detect_Cloud_Separator( K__Sensor, JBAND, I__NumFoundChans, I__GradChkInterval(JBAND), I__Index(1:I__NumFoundChans), & + I__Cloud_Flag, I__FirstCloudyChannel, I__LastClearChannel, I__Scenario_Index, I__Start_Channel, Z__Smooth_DBT(1:I__NumFoundChans)) + + K__Cloud_Flag(IDCHAN(1:I__NumFoundChans)) = & + I__Cloud_Flag(1:I__NumFoundChans) + + ! Set cloud level for cross-band: + IF (I__FirstCloudyChannel == 0) THEN ! FOV is completely clear + Z__Cloud_Level = 1.e20_r_kind ! Large value + ELSE + Z__Cloud_Level = P__Chan_Level(IDCHAN(I__LastClearChannel)) + ENDIF + + ! Automatically do cross band cloud detection for all + ! interferometer channels (whether assigned a band or not) if + ! JBand == 1. This can be over-ridden for the other bands. + + IF (K__Sensor /= INST_ID_AIRS .AND. JBand == 1) & + WHERE(P__Chan_Level(:) < Z__Cloud_Level) K__Cloud_Flag(:) = 0 + + CrossBand : IF (LL__Do_CrossBand) THEN + ! Cross Band: + ! Loop through bands applying cloud detection to those that take their + ! cloud detection information from the current band JBAND. + DO JBand2 = 1, I__Num_Bands + IF (I__BandToUse(JBand2) == JBand) THEN + WHERE(P__Chan_Level(:) < Z__Cloud_Level .AND. & + I__BandNumber == JBand2 .AND. & + P__OBSBTs(:)>0.0_r_kind ) K__Cloud_Flag(:) = 0 + ENDIF + ENDDO + ENDIF CrossBand + +! Deallocate arrays + IF (ALLOCATED(Z__DBT)) DEALLOCATE (Z__DBT) + IF (ALLOCATED(Z__Smooth_DBT)) DEALLOCATE (Z__Smooth_DBT) + IF (ALLOCATED(Z__LEVEL)) DEALLOCATE (Z__LEVEL) + IF (ALLOCATED(I__Cloud_Flag)) DEALLOCATE (I__Cloud_Flag) + IF (ALLOCATED(I__INDEX)) DEALLOCATE (I__INDEX) + IF (ALLOCATED(IDCHAN)) DEALLOCATE (IDCHAN) + + ENDDO Band_Loop + +! Nullify pointers + NULLIFY(I__Band_Size, I__Bands, I__Window_Width, I__BandToUse) + +END SUBROUTINE CADS_Detect_Cloud + +SUBROUTINE CADS_Detect_Cloud_Imager( K__Sensor, K__Nchans, K__Chanid, K__Nclust, K__Cloud_Flag, P__Cl_Fraction, & + P__Cl_Mean, P__Ov_Stddev, P__FG_BT ) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! *CADS_Detect_Cloud_Imager* +! R.Eresmaa ECMWF 12/02/13 + +! * PURPOSE * +! ----------- +! Provide additional information for the cloud detection by making use +! of collocated imager data, such as AVHRR collocated with IASI. + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Detect_Cloud_Imager( )* (from CADS_Detect_Cloud) +! WHERE K__Sensor : Satellite sensor id +! K__Nchans : Number of channels received as input +! K__Chanid : Provided channel IDs +! K__Nclust : Highest possible number of clusters +! K__Cloud_Flag : Output cloud flag (0-7, 0=clear) +! P__Cl_Fraction : Fractional coverage of each cluster within FOV +! P__Cl_Mean : Cluster-mean brightness temperature (BT) on each +! channel +! P__Ov_Stddev : Overall BT standard deviation on each channel +! P__FG_BT : Forward-modelled BT on each channel + +! * METHOD * +! ---------- +! A preliminary indicator of presence of clouds in the sounder +! field-of-view (FOV) is derived using statistical radiance information +! within collocated clusters of imager pixels. + +! * MODIFICATIONS * +! ----------------- +! 03/12/13 R.Eresmaa 2.0 Original export version. +! 19/01/15 R.Eresmaa 2.1 Make array size specifications implicit. +! Verify that channels intended to be used +! are received as input. +! 05/02/19 R.Eresmaa 2.4 Explicit kind specifications. +! 16/04/20 R.Eresmaa 3.0 Rename and tidy up. + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +!* Global arrays + INTEGER(i_kind), INTENT(IN) :: K__Sensor ! Sensor id + INTEGER(i_kind), INTENT(IN) :: K__Nchans ! No. of channels + INTEGER(i_kind), INTENT(IN) :: K__Chanid(:) ! Channel IDs + INTEGER(i_kind), INTENT(IN) :: K__Nclust ! No. of clusters + INTEGER(i_kind), INTENT(OUT) :: K__Cloud_Flag ! Output cloud flag + REAL(r_kind), INTENT(IN) :: P__Cl_Fraction(:) ! Cluster fractions + REAL(r_kind), INTENT(IN) :: P__Cl_Mean(:,:) ! Cluster-mean BTs + REAL(r_kind), INTENT(IN) :: P__Ov_Stddev(:) ! Overall BT st.devs. + REAL(r_kind), INTENT(IN) :: P__FG_BT(:) ! First guess BT + +!* Local variables - Setup of the imager cloud detection + INTEGER(i_kind) :: I__Num_Imager_Chans ! No. of used channels + INTEGER(i_kind), POINTER :: I__Imager_Chans(:) ! List of used channels + REAL(r_kind), POINTER :: Z__Stddev_Threshold(:) ! Homogeneity thresholds + REAL(r_kind) :: Z__Coverage_Threshold ! Coverage threshold + REAL(r_kind) :: Z__FG_Departure_Threshold ! FG departure threshold + +!* Additional local variables + INTEGER(i_kind) :: I, J, IK, I_Temp_Flag, ICOUNT + INTEGER(i_kind) :: I__Chan_Index(K__Nchans) + REAL(r_kind) :: Z__Wsqdev, Z__Intercluster + REAL(r_kind),dimension(K__Nclust) :: Z__Sqdev + + + +!* 1.0 Initialize cloud flags as clear + + K__Cloud_Flag=0 + + IF (S__CADS_Setup_Cloud(K__Sensor) % L__Do_Imager_Cloud_Detection) THEN + + +!* 1.1 Setup + + I__Num_Imager_Chans = & + S__CADS_Setup_Cloud(K__Sensor) % N__Num_Imager_Chans + I__Imager_Chans => & + S__CADS_Setup_Cloud(K__Sensor) % N__Imager_Chans + Z__Stddev_Threshold => & + S__CADS_Setup_Cloud(K__Sensor) % R__Stddev_Threshold + Z__Coverage_Threshold = & + S__CADS_Setup_Cloud(K__Sensor) % R__Coverage_Threshold + Z__FG_Departure_Threshold = & + S__CADS_Setup_Cloud(K__Sensor) % R__FG_Departure_Threshold + + + +!* 1.2 Channel indexing + I__Chan_Index(:) = 0 + ICOUNT=0 + DO I=1,K__Nchans + IK=0 + DO J=1,I__Num_Imager_Chans + IF (K__Chanid(I)==I__Imager_Chans(J)) THEN + ICOUNT=ICOUNT+1 + IK=ICOUNT + EXIT + ENDIF + ENDDO + I__Chan_Index(I)=IK + ENDDO + + +!* 2.0 Compute squared first guess departures for each cluster + + DO J=1,K__Nclust + Z__Sqdev(J) = 0.0_r_kind + DO I=1,K__Nchans + IF (I__Chan_Index(I)==0) CYCLE + Z__Sqdev(J) = Z__Sqdev(J) + (P__Cl_Mean(I,J)-P__FG_BT(I))**2 + ENDDO + ENDDO + +!* 2.1 Homogeneity check: Do not diagnose presence of cloud if BT +! standard deviation falls below given threshold on at least one +! channel. + + I_Temp_Flag=1 + DO I=1,K__Nchans + IF (I__Chan_Index(I)==0) CYCLE + IF (P__Ov_Stddev(I)Z__Sqdev(J) .OR. Z__Intercluster>Z__Sqdev(IK)) THEN + K__Cloud_Flag=K__Cloud_Flag+2 + Exit Consistency_Check + ENDIF + ENDDO + ENDDO Consistency_Check + + +!* 2.3 First guess departure check: Do not diagnose presence of cloud +! if fraction-weighted first guess departure falls below given +! threshold. + + Z__Wsqdev = SUM(P__Cl_Fraction(:)*Z__Sqdev(:)) + IF (Z__Wsqdev>=Z__FG_Departure_Threshold) K__Cloud_Flag=K__Cloud_Flag+1 + + ENDIF ! L__Do_Imager_Cloud_Detection + +END SUBROUTINE CADS_Detect_Cloud_Imager + + +SUBROUTINE CADS_Detect_Cloud_Heapsort(N, A, K_Index) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud_Heapsort * +! A.Collard ECMWF 01/02/06 + +! * PURPOSE * +! ----------- +! Basic heapsort algorithm. + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Detect_Cloud_Heapsort( )* (from CADS_Detect_Cloud) +! WHERE N : Length of input array +! A : Real input array +! K_Index : Output ranked array + +! * MODIFICATIONS * +! ----------------- +! 16/05/06 A.Collard 1.0 Original version. +! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications +! 16/04/20 R.Eresmaa 3.0 Rename as part of the big clean for CADS V3 + + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +! Subroutine arguments + INTEGER(i_kind), INTENT(IN) :: N + REAL(r_kind), INTENT(IN) :: A(:) + INTEGER(i_kind), INTENT(INOUT) :: K_Index(:) + + INTEGER(i_kind) :: I,J,RIGHT,LEFT,IDX + REAL(r_kind) :: TMP + +!------------------------------------------ + + IF (N <= 1) RETURN + LEFT = N/2+1 + RIGHT = N + + DO + IF (LEFT > 1) THEN + LEFT = LEFT - 1 + IDX = K_Index(LEFT) + ELSE + IDX = K_Index(RIGHT) + K_Index(RIGHT) = K_Index(1) + RIGHT = RIGHT - 1 + IF (RIGHT == 1) THEN + K_Index(1) = IDX + EXIT + ENDIF + ENDIF + TMP = A(IDX) + I = LEFT + J = 2*LEFT + DO WHILE (J <= RIGHT) + IF (J < RIGHT) THEN + IF (A(K_Index(J)) < A(K_Index(J+1))) J = J + 1 + ENDIF + IF (TMP < A(K_Index(J))) THEN + K_Index(I) = K_Index(J) + I = J + J = 2*J + ELSE + J = RIGHT + 1 + ENDIF + ENDDO + K_Index(I) = IDX + ENDDO + +END SUBROUTINE CADS_Detect_Cloud_Heapsort + +SUBROUTINE CADS_Detect_Cloud_Smooth(KV,KW,PV,PVA) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud_Smooth * - Boxcar-averaging in a REAL array +! * Phil Watts ECMWF 24/01/02 + +! * PURPOSE * +! ----------- +! Calculate the moving average (smoothing filter) of array +! No error checking supplied. + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Detect_Cloud_Smooth( )* (from CADS_Detect_Cloud) +! WHERE KV : Number of elements in V +! KW : Window width for filter +! PV : Input array to be averaged +! PVA : Averaged array + +! * MODIFICATIONS * +! ----------------- +! 01/02/06 A.Collard 1.0 Original export version. +! 13/01/15 R.Eresmaa 2.1 Make array size specifications implicit. +! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! 16/04/20 R.Eresmaa 3.0 Rename and tidy up. + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +!* 0.1 global variables + INTEGER(i_kind), INTENT(IN) :: KV ! length of V + INTEGER(i_kind), INTENT(IN) :: KW ! length of averaging window + REAL(r_kind), INTENT(IN) :: PV(:) ! original array + REAL(r_kind), INTENT(INOUT) :: PVA(:) ! averaged array + +!* 0.2 local variables + INTEGER(i_kind) :: INJ,J,I + + PVA(:)=0.0_r_kind + + DO I = 1,KV ! loop over array elements + INJ=0 + DO J=I-KW/2,I+KW/2,1 ! loop over window + IF (J > 0 .AND. J < (KV+1)) THEN ! if window element exists in + ! original array + INJ=INJ+1 + PVA(I)=PVA(I)+PV(J) ! add value + ENDIF + ENDDO + PVA(I)=PVA(I)/REAL(INJ) ! mean value + ENDDO + +END SUBROUTINE CADS_Detect_Cloud_Smooth + +SUBROUTINE CADS_Detect_Cloud_Scenario( K__Sensor, K__Band, K__NumChans, K__GradChkInterval, K__Index, K__Chan_High, & + K__Chan_Low, K__Chan_Windows, K__Imager_Flag, K__Scen_Index, K__Start_Channel, P__DBT) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud_Scenario * +! PHIL WATTS ECMWF 21/01/02 + +! * PURPOSE * +! ----------- +! Determine which of the three possible scenarios best describes +! the input data. +! Quick Exit - no cloud in the FOV +! Warm Start - warm cloud above relatively colder surface +! Cold Start - cold cloud above relatively warmer surface (most common) + +! * INTERFACE * +! ------------- +! * CALL* * CADS_Detect_Cloud_Scenario( )* (from CADS_Detect_Cloud) +! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS) +! K__Band : Band number +! K__NumChans : Number of channels in this band +! K__GradChkInterval : Gradient-checking interval +! K__Index : Ranking index for the input dBT signal +! K__Chan_High : High channel considered in initial minimum search +! K__Chan_Low : Low channel considered in initial minimum search +! K__Chan_Windows : Two channels defining longwave window +! K__Imager_Flag : Input flag from collocated imager data +! K__Scen_Index : Choice of cloud detection scenario (1, 2, or 3) +! K__Start_Channel : Channel index for the start of final search +! P__DBT : Input dBT signal + +! * MODIFICATIONS * +! ----------------- +! 03/02/06 A.Collard 1.0 Tidy up in preparation for IASI +! 03/05/06 A.Collard 1.0.1 Band size is now passed in (allows for +! missing channels). +! 04/05/06 A.Collard 1.0.2 The index of the first cloudy channel is now +! returned to allow cross-band cloud detection +! 16/02/07 A.Collard 1.0.3 Change to the padding to allow the bottom +! channel to be flagged as clear in a +! non-quickstart situation. +! 16/01/09 A.Collard 1.1 Gradient check on quick exit +! Start channel for cold start moved to highest +! channel where BT threshold exceeded +! 11/11/11 R.Eresmaa 1,2 Index of the lowest clear channel added to +! the output parameters. +! Change of the starting channel is no longer +! allowed in cases where gradient > -threshold. +! 04/12/13 R.Eresmaa 2.0 Allow quick exit only if collocated imager +! data supports hypothesis of a clear FOV +! 13/01/15 R.Eresmaa 2.1 Remove the need to create temporary array in +! the call to MOVINGA. +! the call to MOVINGA. +! 04/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! 16/04/20 R.Eresmaa 3.0 Divide the previous CF_Digital in two: +! Cloud_Scenario (here) and Cloud_Separator. + + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +!* 0.1 Global arrays + INTEGER(i_kind), INTENT(IN) :: K__SENSOR ! Sensor + INTEGER(i_kind), INTENT(IN) :: K__Band ! Band number + INTEGER(i_kind), INTENT(IN) :: K__NumChans ! Number of usable channels in band + INTEGER(i_kind), INTENT(IN) :: K__GradChkInterval ! Gradient-check interval + INTEGER(i_kind), INTENT(IN) :: K__INDEX(:) ! Ranking index for dBT + INTEGER(i_kind), INTENT(IN) :: K__Chan_High ! First channel clear of high stratospheric model errors + INTEGER(i_kind), INTENT(IN) :: K__Chan_Low ! Last channel clear of PBL humidity errors + INTEGER(i_kind), INTENT(IN) :: K__Chan_Windows(2) ! Two channels defining long-wave window bounds + INTEGER(i_kind), INTENT(IN) :: K__Imager_Flag ! Input imager cloud flag + INTEGER(i_kind), INTENT(OUT) :: K__Scen_Index ! Choice of scenario + INTEGER(i_kind), INTENT(OUT) :: K__Start_Channel ! Final starting channel + REAL(r_kind), INTENT(IN) :: P__DBT(:) ! Input ranked-smoothed dBT signal + +! Local variables + REAL(r_kind), ALLOCATABLE :: Z__DBT_w_Buffer(:) ! Smoothed-ranked DBT + INTEGER(i_kind) :: I__Buffer ! No. of buffer channels + INTEGER(i_kind) :: I__Start_Channel ! Primary starting channel for cloud search + INTEGER(i_kind) :: I__Start_Channel_Surf ! Secondary starting channel for cloud search + INTEGER(i_kind) :: I__Max_Channel ! Channel corresponding to maximum of the smoothed dBT + INTEGER(i_kind) :: JCH,JMIN(1),JMAX(1),I + + LOGICAL :: LLCOLD, LL__WINDOW_GRAD_CHECK, LL__StartChannelChanged + LOGICAL :: LL__Search_for_Cloud_Top + +! These carry the values in S__CADS_Setup_Cloud + REAL(r_kind) :: Z__BT_Threshold ! Solution contaminated threshold + REAL(r_kind) :: Z__Grad_Threshold ! Gradient threshold at which to stop filter procession + REAL(r_kind) :: Z__Window_Grad_Threshold ! Gradient threshold for window check + + +!============================================================================= + + + Z__BT_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__BT_Threshold(K__Band) + Z__Grad_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__Grad_Threshold(K__Band) + Z__Window_Grad_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__Window_Grad_Threshold(K__Band) + + +!1. Include buffer channels at the start and end of the input smoothed +! departure array + + I__BUFFER = K__GradChkInterval + ALLOCATE(Z__DBT_w_Buffer(-I__Buffer+1:K__NumChans+1)) + + Z__DBT_w_Buffer(1:K__NumChans) = P__DBT(:) + Z__DBT_w_Buffer(-I__BUFFER+1:0) = Z__DBT_w_Buffer(1) + Z__DBT_w_Buffer(K__NumChans+1) = Z__DBT_w_Buffer(K__NumChans) + + +!2. Prepare for the cloud search + +! First define a set of key channels + + JMIN=MINLOC(Z__DBT_w_Buffer(K__Chan_High:K__NumChans)) + I__Start_Channel_Surf = K__Chan_High+JMIN(1)-1 + + JMIN=MINLOC(Z__DBT_w_Buffer(K__Chan_High:K__Chan_Low)) + I__Start_Channel = K__Chan_High+JMIN(1)-1 + +! Look for highest channel with DBT<-BT_Threshold and move I__Start_Channel +! there if higher than current I__Start_Channel: + JCH = I__Start_Channel + StartChanLoop : DO I=K__Chan_High,K__NumChans + IF (Z__DBT_w_Buffer(I) < -Z__BT_Threshold .OR. I == I__Start_Channel) THEN + JCH = I + Exit StartChanLoop + ENDIF + ENDDO StartChanLoop + I__Start_Channel = JCH + +! Do the same with I__Start_Channel_Surf + JCH = I__Start_Channel_Surf + StartChanLoop_Surf : DO I=K__Chan_High,K__NumChans + IF (Z__DBT_w_Buffer(I) < -Z__BT_Threshold .OR. I == I__Start_Channel_Surf) THEN + JCH = I + Exit StartChanLoop_Surf + ENDIF + ENDDO StartChanLoop_Surf + I__Start_Channel_Surf = JCH + +! Find the position of the equivalent maximum departure (for quick exit test) + JMAX=MAXLOC(Z__DBT_w_Buffer(K__Chan_High:K__NumChans)) + I__Max_Channel = K__Chan_High+JMAX(1)-1 + +! Long-wave window gradient check + LL__WINDOW_GRAD_CHECK=.TRUE. + IF (ALL(K__Chan_Windows > 0)) LL__WINDOW_GRAD_CHECK = & + (ABS(Z__DBT_w_Buffer(K__INDEX(K__Chan_Windows(1))) - & + Z__DBT_w_Buffer(K__INDEX(K__Chan_Windows(2)))) & + < Z__Window_Grad_Threshold) + +! Choose scenario to be followed + LL__Search_for_Cloud_Top=.TRUE. + IF (ABS(Z__DBT_w_Buffer(I__Start_Channel_Surf)) < Z__BT_Threshold .AND. & + ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. & + ABS(Z__DBT_w_Buffer(I__Max_Channel)) < Z__BT_Threshold .AND. & + ABS(Z__DBT_w_Buffer(K__NumChans)) < Z__BT_Threshold .AND. & + LL__WINDOW_GRAD_CHECK .AND. & + K__Imager_Flag==0 .AND. & + S__CADS_Setup_Cloud(K__SENSOR) % L__Do_Quick_Exit) THEN + !Quick exit + LL__Search_for_Cloud_Top=.FALSE. + ELSEIF (ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. & + Z__DBT_w_Buffer(K__NumChans) > Z__BT_Threshold ) THEN + !Warm cloud start at next-to-bottom channel (allowing one channel for + !gradient calculations). + LLCOLD = .FALSE. + I__Start_Channel = K__NumChans-1 + ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) < -Z__BT_Threshold ) THEN + LLCOLD = .TRUE. + ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) > Z__BT_Threshold ) THEN + LLCOLD = .FALSE. + ELSE + LLCOLD = .TRUE. + ENDIF + + IF (LL__Search_for_Cloud_Top) THEN ! Either cold or warm start + ! (but not quick exit) + + JCH=I__Start_Channel + +! Re-evaluate the choice of scenario: +! If the primary starting channel appears clear, and the secondary +! starting channel is lower, start from the latter. In that case +! re-evaluate whether cold or warm start is more appropriate. + IF (I__Start_Channel /= I__Start_Channel_Surf) THEN + + LL__StartChannelChanged = .FALSE. + IF (LLCOLD .AND. ( (Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) < & + Z__Grad_Threshold .AND. & + Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1) < & + Z__Grad_Threshold .AND. & + ABS(Z__DBT_w_Buffer(JCH)) < Z__BT_Threshold)) THEN + I__Start_Channel = I__Start_Channel_Surf + LL__StartChannelChanged = .TRUE. + ENDIF + + IF (LL__StartChannelChanged) THEN + + IF (ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. & + Z__DBT_w_Buffer(K__NumChans) > Z__BT_Threshold ) THEN + !Warm cloud start at next-to-bottom channel (allowing one channel for + !gradient calculations). + LLCOLD = .FALSE. + I__Start_Channel = K__NumChans-1 + ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) < -Z__BT_Threshold ) THEN + LLCOLD = .TRUE. + ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) > Z__BT_Threshold ) THEN + LLCOLD = .FALSE. + ELSE + LLCOLD = .TRUE. + ENDIF + JCH = I__Start_Channel + + ENDIF + ENDIF + + IF (LLCOLD) THEN + K__Scen_Index=3 + ELSE + K__Scen_Index=2 + ENDIF + K__Start_Channel = JCH + + ELSE + + K__Scen_Index=1 + K__Start_Channel=0 + + ENDIF ! Search for cloud top + + IF (ALLOCATED(Z__DBT_w_Buffer)) DEALLOCATE(Z__DBT_w_Buffer) + +END SUBROUTINE CADS_Detect_Cloud_Scenario + +SUBROUTINE CADS_Detect_Cloud_Separator( K__Sensor, K__Band, K__NumChans, K__GradChkInterval, K__Index, K__Cloud_Flag, & + K__Cloud_Level, K__Clear_Level, K__Scen_Index, K__Start_Channel, P__DBT) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud_Separator * +! PHIL WATTS ECMWF 21/01/02 + +! * PURPOSE * +! ----------- +! Along the vertically-ranked and smoothed array of departures, find +! the separating point at which all cloud-affected channels are on +! one side and all clear channels are on the other side. + +! * INTERFACE * +! ------------ +! * CALL* * CADS_Detect_Cloud_Separator( )* (from CADS_Detect_Cloud) +! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS) +! K__Band : Band number +! K__NumChans : Number of channels in this band +! K__GradChkInterval : Gradient-checking interval +! K__Index : Ranking index for the input dBT signal +! K__Cloud_Flag : Cloud flag by channel; 0=clear, 1=cloudy +! K__Cloud_Level : Index of the highest cloud-contaminated channel +! K__Clear_Level : Index of the lowest clear channel +! K__Scen_Index : Choice of cloud detection scenario (1, 2, or 3) +! K__Start_Channel : Starting channel for the cloud search +! P__DBT : Input dBT signal + +! MODIFICATIONS +! 03/02/06 A.Collard 1.0 Tidy up in preparation for IASI +! 03/05/06 A.Collard 1.0.1 Band size is now passed in (allows for +! missing channels). +! 04/05/06 A.Collard 1.0.2 The index of the first cloudy channel is now +! returned to allow cross-band cloud detection +! 16/02/07 A.Collard 1.0.3 Change to the padding to allow the bottom +! channel to be flagged as clear in a +! non-quickstart situation. +! 16/01/09 A.Collard 1.1 Gradient check on quick exit +! Start channel for cold start moved to highest +! channel where BT threshold exceeded +! 11/11/11 R.Eresmaa 1,2 Index of the lowest clear channel added to +! the output parameters. +! Change of the starting channel is no longer +! allowed in cases where gradient > -threshold. +! 04/12/13 R.Eresmaa 2.0 Allow quick exit only if collocated imager +! data supports hypothesis of a clear FOV +! 13/01/15 R.Eresmaa 2.1 Remove the need to create temporary array in +! the call to MOVINGA. +! 04/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! 16/04/20 R.Eresmaa 3.0 Divide the previous CF_Digital in two: +! Cloud_Scenario and Cloud_Separator (here). + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +!* 0.1 Global arrays + INTEGER(i_kind), INTENT(IN ) :: K__SENSOR ! Sensor + INTEGER(i_kind), INTENT(IN ) :: K__Band ! Band number + INTEGER(i_kind), INTENT(IN ) :: K__NumChans ! Number of usable channels in band + INTEGER(i_kind), INTENT(IN ) :: K__GradChkInterval ! Gradient-check interval + INTEGER(i_kind), INTENT(IN ) :: K__INDEX(:) ! Ranking index for dBT + INTEGER(i_kind), INTENT(INOUT) :: K__Cloud_Flag(:) ! Cloud flags + INTEGER(i_kind), INTENT( OUT) :: K__Cloud_Level ! Index of highest cloudy channel + INTEGER(i_kind), INTENT( OUT) :: K__Clear_Level ! Index of lowest clear channel + INTEGER(i_kind), INTENT(IN ) :: K__Scen_Index ! Choice of scenario + INTEGER(i_kind), INTENT(IN ) :: K__Start_Channel ! Choice of scenario + REAL(r_kind), INTENT(IN ) :: P__DBT(:) ! Input ranked dBT signal + + +! Local variables + REAL(r_kind), ALLOCATABLE :: Z__DBT_w_Buffer(:) ! Smoothed-ranked DBT + INTEGER(i_kind) :: I__Buffer ! No. of buffer channels + INTEGER(i_kind) :: JCH + +! These carry the values in S__CADS_Setup_Cloud + REAL(r_kind) :: Z__BT_Threshold ! Solution contaminated threshold + REAL(r_kind) :: Z__Grad_Threshold ! Gradient threshold at which to stop + ! filter procession + +!============================================================================= + + + Z__BT_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__BT_Threshold(K__Band) + Z__Grad_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__Grad_Threshold(K__Band) + + K__Cloud_Flag(:)=1 + +!1. Include buffer channels at the start and end of the input smoothed +! departure array + + I__BUFFER = K__GradChkInterval + ALLOCATE(Z__DBT_w_Buffer(-I__Buffer+1:K__NumChans+1)) + + Z__DBT_w_Buffer(1:K__NumChans) = P__DBT(:) + Z__DBT_w_Buffer(-I__BUFFER+1:0) = Z__DBT_w_Buffer(1) + Z__DBT_w_Buffer(K__NumChans+1) = Z__DBT_w_Buffer(K__NumChans) + + +!2. Search for the lowest non-contaminated channel + + JCH = K__Start_Channel + + SELECT CASE (K__Scen_Index) + + CASE (1) ! Quick Exit + K__Cloud_Level = 0 + + CASE (2) ! Warm Start +! In the case of Warm Start, progress towards higher channels whilst +! -ve difference is decreasing + DO WHILE ( ((Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) < & + -1.0_r_kind * Z__Grad_Threshold .OR. & + (Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1)) < & + -1.0_r_kind * Z__Grad_Threshold .OR. & + ABS(Z__DBT_w_Buffer(JCH)) > Z__BT_Threshold) .AND. JCH > 1 ) + JCH = JCH-1 + ENDDO + K__Cloud_Level = JCH + + CASE (3) ! Cold Start +! In the case of Cold Start, progress towards higher channels whilst +! -ve difference is decreasing + DO WHILE (( (Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) > & + Z__Grad_Threshold .OR. & + (Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1)) > & + Z__Grad_Threshold .OR. & + ABS(Z__DBT_w_Buffer(JCH)) > Z__BT_Threshold) .AND. JCH > 1 ) + JCH = JCH-1 + ENDDO + K__Cloud_Level = JCH + + CASE DEFAULT + RETURN + + END SELECT + +!3. Output channel indices for the highest cloud and lowest clear levels + IF (K__Cloud_Level > 1) THEN + K__Cloud_Flag(K__INDEX(1:K__Cloud_Level-1))=0 + K__Clear_Level=K__INDEX(K__Cloud_Level-1) + K__Cloud_Level=K__INDEX(K__Cloud_Level) + ELSEIF (K__Cloud_Level>0) THEN + K__Clear_Level=K__INDEX(K__Cloud_Level) + K__Cloud_Level=K__INDEX(K__Cloud_Level) + ELSE + K__Cloud_Flag(:)=0 + ENDIF + + IF (ALLOCATED(Z__DBT_w_Buffer)) DEALLOCATE(Z__DBT_w_Buffer) + +END SUBROUTINE CADS_Detect_Cloud_Separator + +subroutine cads_imager_calc(obstype,isis,nobs,nreal,nchanl,nsig,data_s,init_pass,mype, & + imager_cluster_fraction,imager_cluster_bt,imager_chan_stdev, imager_model_bt) + +!$$$ subprogram documentation block +! +! subprogram: cads_imager_calc compute model equivalent to the imager channels used by CADS +! prgmmr: Jung +! +! abstract: accumulate the data necessary to derive the model equivalent brightness temperatures +! used by the cloud and aerosol detection software for the imager cloud tests. +! +! program history log: +! +! +! +! subroutines included: +! +! +! input argument list: +! +! obstype - type of tb observation +! isis - sensor/instrument/satellite id +! nobs - number of observations +! nreal - number of pieces of info (location, time, etc) per obs +! nchanl - number of channels per obs +! nsig - number of model layers +! data_s - array containing input data information for a specific sensor +! init_pass - state of "setup" processing +! mype - mpi task id +! +! output argument list: + +! imager_cluster_fraction - CADS cluster fraction ( dimension 7) +! imager_cluster_bt - avreage brightness temperature of a cluster +! imager_chan stdev - brightness temperature standard deviation of the cluster +! imager_model_bt - model derived brightness temperature +! +! +!$$$ end documentation block + + use kinds, only: i_kind, r_kind + use constants, only: zero + use radiance_mod, only: rad_obs_type + use radinfo, only: jpch_rad, nusis, crtm_coeffs_path, nsigradjac + use crtm_interface, only: init_crtm, call_crtm, destroy_crtm, itime + use obsmod, only: dval_use + use gsi_nstcouplermod, only: nstinfo + + implicit none + + logical, intent(in) :: init_pass + character(len=10), intent(in) :: obstype + character(len=20), intent(in) :: isis + integer(i_kind), intent(in) :: nobs, nreal, nchanl, nsig + integer(i_kind), intent(in) :: mype + real(r_kind),dimension(nreal+nchanl,nobs),intent(in) :: data_s + real(r_kind),dimension(7,nobs), intent(out) :: imager_cluster_fraction + real(r_kind),dimension(2,7,nobs), intent(out) :: imager_cluster_bt + real(r_kind),dimension(2,nobs), intent(out) :: imager_chan_stdev, imager_model_bt + +! local variables + integer(i_kind) :: jc, i, n + integer(i_kind) :: itmp1_cads, itmp2_cads, nchanl_cads, maxinfo, dval_info, cads_info, error_status + integer(i_kind),allocatable,dimension(:) :: ich_cads + logical :: imager_spccoeff, imager_taucoeff + real(r_kind) :: dtime, clw_guess, ciw_guess, rain_guess, snow_guess + real(r_kind) :: trop5, tzbgr, dtsavg, sfc_speed + real(r_kind),dimension(nsig) :: qvp, tvp, qs, prsltmp + real(r_kind),dimension(nsig+1) :: prsitmp + real(r_kind),allocatable,dimension(:) :: tsim_cads, emissivity_cads, chan_level_cads + real(r_kind),allocatable,dimension(:) :: ts_cads, emissivity_k_cads,data_s_cads + real(r_kind),allocatable,dimension(:,:) :: ptau5_cads, temp_cads, wmix_cads, jacobian_cads + character(len=80) :: spc_filename, tau_filename + character(len=20) :: isis_cads + character(len=10) :: obstype_cads + + type(rad_obs_type) :: radmod + + cads_info = 23 + dval_info = 0 + if (dval_use) dval_info = 2 + + itmp1_cads = len(trim(obstype)) + itmp2_cads = len(trim(isis)) + + if ( obstype == 'iasi' ) then + isis_cads = 'avhrr3'//isis(itmp1_cads+1:itmp2_cads) + obstype_cads = 'avhrr' +! nchanl_cads = 3 !channels 3 - 5 + elseif ( obstype == 'cris' .or. obstype == 'cris-fsr' ) then +! isis_cads = 'viirs-m'//isis(itmp1+1:itmp2) When naming convention becomes standarized with CrIS + if ( isis == 'cris-fsr_npp' .or. isis == 'cris_npp' ) then + isis_cads = 'viirs-m_npp' + elseif ( isis == 'cris-fsr_n20' ) then + isis_cads = 'viirs-m_n20' + spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin' + inquire(file=trim(spc_filename), exist=imager_spccoeff) + if ( .not. imager_spccoeff ) isis_cads = 'viirs-m_j1' + elseif ( isis == 'cris-fsr_n21' ) then + isis_cads = 'viirs-m_n21' + spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin' + inquire(file=trim(spc_filename), exist=imager_spccoeff) + if ( .not. imager_spccoeff ) isis_cads = 'viirs-m_j2' + endif + obstype_cads = 'viirs-m' +! nchanl_cads = 5 ! channels 12 - 16 + endif + + spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin' + inquire(file=trim(spc_filename), exist=imager_spccoeff) + tau_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.TauCoeff.bin' + inquire(file=trim(tau_filename), exist=imager_taucoeff) + +! IF the RTM files exist allocate and setup various arrays for the RTM + if ( imager_spccoeff .and. imager_taucoeff) then + nchanl_cads = 0 + do i=1,jpch_rad + if (trim(isis_cads) == nusis(i)) then + nchanl_cads = nchanl_cads +1 + endif + end do + + allocate( ich_cads(nchanl_cads) ) + jc = 0 + do i=1,jpch_rad + if (trim(isis_cads) == nusis(i)) then + jc = jc +1 + ich_cads(jc) = i + endif + end do + + call init_crtm(init_pass,-99,mype,nchanl_cads,nreal,isis_cads,obstype_cads,radmod) + +! Initialize variables needed for the infrared cloud and aerosol detection software + allocate(data_s_cads(nreal+nchanl_cads),tsim_cads(nchanl_cads),emissivity_cads(nchanl_cads), & + chan_level_cads(nchanl_cads),ptau5_cads(nsig,nchanl_cads),ts_cads(nchanl_cads),emissivity_k_cads(nchanl_cads), & + temp_cads(nsig,nchanl_cads),wmix_cads(nsig,nchanl_cads), jacobian_cads(nsigradjac,nchanl_cads)) + + do n = 1,nobs ! loop to derive imager BTs for CADS +! Extract analysis relative observation time. + dtime = data_s(itime,n) + maxinfo = nreal - cads_info - dval_info - nstinfo + if ( sum(data_s(maxinfo+1:maxinfo+7,n)) > 0.90_r_kind ) then ! imager cluster information exists for this profile + data_s_cads = data_s(1:nreal+nchanl_cads,n) + call call_crtm(obstype_cads,dtime,data_s_cads,nchanl_cads,nreal,ich_cads, & + tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & + trop5,tzbgr,dtsavg,sfc_speed,tsim_cads,emissivity_cads,chan_level_cads, & + ptau5_cads,ts_cads,emissivity_k_cads,temp_cads,wmix_cads,jacobian_cads,error_status) + +! Transfer imager data to arrays for qc_irsnd + imager_cluster_fraction(1:7,n) = data_s(maxinfo+1:maxinfo+7,n) + imager_cluster_bt(1,1:7,n) = data_s(maxinfo+8:maxinfo+14,n) + imager_cluster_bt(2,1:7,n) = data_s(maxinfo+15:maxinfo+21,n) + imager_chan_stdev(1:2,n) = data_s(maxinfo+22:maxinfo+23,n) + imager_model_bt(1:2,n) = tsim_cads(nchanl_cads-1:nchanl_cads) + endif ! imager information exists + end do ! End loop to derive imager BTs + + call destroy_crtm + deallocate(data_s_cads,tsim_cads,emissivity_cads, ich_cads,chan_level_cads,ptau5_cads,& + ts_cads,emissivity_k_cads, temp_cads,wmix_cads, jacobian_cads) + endif ! RTM files exist + + end subroutine cads_imager_calc + +end module cads diff --git a/src/gsi/crtm_interface.f90 b/src/gsi/crtm_interface.f90 index 2305c84340..4bb1191001 100644 --- a/src/gsi/crtm_interface.f90 +++ b/src/gsi/crtm_interface.f90 @@ -977,7 +977,7 @@ end subroutine destroy_crtm subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & h,q,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsl,prsi, & trop5,tzbgr,dtsavg,sfc_speed,& - tsim,emissivity,ptau5,ts, & + tsim,emissivity,chan_level,ptau5,ts, & emissivity_k,temp,wmix,jacobian,error_status,tsim_clr,tcc, & tcwv,hwp_ratio,stability,layer_od,jacobian_aero) !$$$ subprogram documentation block @@ -1097,6 +1097,7 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & real(r_kind) ,intent( out) :: sfc_speed,dtsavg real(r_kind),dimension(nchanl+nreal) ,intent(in ) :: data_s real(r_kind),dimension(nchanl) ,intent( out) :: tsim,emissivity,ts,emissivity_k + real(r_kind),dimension(nchanl) ,intent( out) :: chan_level character(10) ,intent(in ) :: obstype integer(i_kind) ,intent( out) :: error_status real(r_kind),dimension(nsig,nchanl) ,intent( out) :: temp,ptau5,wmix @@ -1150,6 +1151,7 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & real(r_kind):: sno00,sno01,sno10,sno11,secant_term real(r_kind):: hwp_total,theta_700,theta_sfc,hs real(r_kind):: dlon,dlat,dxx,dyy,yy,zz,garea + real(r_kind):: radiance, radiance_overcast, radiance_ratio real(r_kind),dimension(0:3):: wgtavg real(r_kind),dimension(nsig,nchanl):: omix real(r_kind),dimension(nsig,nchanl,n_aerosols_jac):: jaero @@ -2217,8 +2219,10 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & end do end if + chan_level = zero + !$omp parallel do schedule(dynamic,1) private(i) & -!$omp private(total_od,k,kk,m,term,ii,cwj) +!$omp private(total_od,k,kk,m,term,ii,cwj,radiance,radiance_overcast,radiance_ratio) do i=1,nchanl ! Zero jacobian and transmittance arrays do k=1,nsig @@ -2228,6 +2232,16 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & wmix(k,i)=zero end do + radiance=rtsolution(i,1)%radiance + do k=msig, 1, -1 + radiance_overcast = rtsolution(i,1)%upwelling_overcast_radiance(k) + radiance_ratio = abs(radiance_overcast/radiance) + if (radiance_ratio < 0.99_r_kind) then + chan_level(i) = atmosphere(1)%pressure(k) / r10 + exit + endif + enddo + ! Simulated brightness temperatures tsim(i)=rtsolution(i,1)%brightness_temperature diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index 5a7d29c208..ce74d91c63 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -101,6 +101,7 @@ bkgvar_rewgt.f90 blacklist.f90 blendmod.f90 buddycheck_mod.f90 +cads.f90 calc_fov_conical.f90 calc_fov_crosstrk.f90 calctends.f90 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index c24c485ce1..45d88887a3 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -93,8 +93,14 @@ module gsimod erradar_inflate,tdrerr_inflate,use_poq7,qc_satwnds,& init_qcvars,vadfile,noiqc,c_varqc,gps_jacqc,qc_noirjaco3,qc_noirjaco3_pole,& buddycheck_t,buddydiag_save,njqc,vqc,nvqc,hub_norm,vadwnd_l2rw_qc, & - pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cao_check + pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cao_check, & + cris_cads, iasi_cads, airs_cads use qcmod, only: troflg,lat_c,nrand + use cads, only: M__Sensor,N__Num_Bands,N__GradChkInterval,N__Band_Size,N__Bands,N__Window_Width, & + N__Window_Bounds,R__BT_Threshold,R__Grad_Threshold,R__Window_Grad_Threshold, L__Do_Quick_Exit, & + L__Do_CrossBand, N__BandToUse,L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, & + N__Num_Imager_Clusters,N__Imager_Chans,R__Stddev_Threshold,R__Coverage_Threshold, & + R__FG_Departure_Threshold, CADS_Setup_Cloud use pcpinfo, only: npredp,diag_pcp,dtphys,deltim,init_pcp use jfunc, only: iout_iter,iguess,miter,factqmin,factqmax,superfact,limitqobs, & factql,factqi,factqr,factqs,factqg, & @@ -507,6 +513,9 @@ module gsimod ! 2. fv3_regional = .true. ! 3. fv3_cmaq_regional = .true. ! 4. berror_fv3_cmaq_regional = .true. +! 09-02-2022 Jung Added namelist entries to call a new IR cloud detection routine +! the original cloud detection routine is the default. To use the new +! cloud detection routine, set the flags to .true. ! 09-15-2022 yokota - add scale/variable/time-dependent localization ! 2023-07-30 Zhao - added namelist options for analysis of significant wave height ! (aka howv in GSI code): corp_howv, hwllp_howv @@ -1051,6 +1060,13 @@ module gsimod ! wind observations. ! vad_near_analtime - assimilate newvadwnd obs around analysis time only +! +! Flags to use the new IR cloud detection routine. Flag must be set to true to use the new routine. The default +! (no flag or .false.) will use the default. +! airs_cads: use the clod and aerosool detection software for the AIRS instrument +! cris_cads: use the cloud and aerosol detection software for CrIS instruments +! iasi_cads: use the cloud and aerosol detection software for IASI instruments +! namelist/obsqc/dfact,dfact1,erradar_inflate,tdrerr_inflate,oberrflg,& vadfile,noiqc,c_varqc,blacklst,use_poq7,hilbert_curve,tcp_refps,tcp_width,& @@ -1061,7 +1077,7 @@ module gsimod q_doe_a_136,q_doe_a_137,q_doe_b_136,q_doe_b_137, & t_doe_a_136,t_doe_a_137,t_doe_b_136,t_doe_b_137, & uv_doe_a_236,uv_doe_a_237,uv_doe_a_213,uv_doe_b_236,uv_doe_b_237,uv_doe_b_213, & - vad_near_analtime + vad_near_analtime,airs_cads,cris_cads,iasi_cads ! OBS_INPUT (controls input data): ! dmesh(max(dthin))- thinning mesh for each group @@ -1663,6 +1679,40 @@ module gsimod ! fac_tsl - index to apply thermal skin layer or not: 0 = no; 1 = yes. namelist/nst/nst_gsi,nstinfo,zsea1,zsea2,fac_dtl,fac_tsl +! Initialize the Cloud and Aerosol Detection Software (CADS) +! +! M__Sensor Unique ID for sensor +! N__Num_Bands Number of channel bands +! N__Band_Size(:) Number of channels in each band +! N__Bands(:,:) Channel lists +! N__Window_Width(:) Smoothing filter window widths per band +! N__Window_Bounds(:,:) Channels in the spectral window gradient check +! N__GradChkInterval(:) Window width used in gradient calculation +! R__BT_Threshold(:) BT threshold for cloud contamination +! R__Grad_Threshold(:) Gradient threshold for cloud contamination +! R__Window_Grad_Threshold(:) Threshold for window gradient check in QE +! L__Do_Quick_Exit On/off switch for the Quick Exit scenario +! L__Do_CrossBand On/off switch for the cross-band method +! N__BandToUse(:) Band number assignment for each channel +! L__Do_Imager_Cloud_Detection On/off switch for the imager cloud detection +! N__Num_Imager_Chans No. of imager channels +! N__Num_Imager_Clusters No. of clusters to be expected +! N__Imager_Chans(:) List of imager channels +! R__Stddev_Threshold(:) St. Dev. threshold, one for each imager channel +! R__Coverage_Threshold Threshold for fractional coverage of a cluster +! R__FG_Departure_Threshold Threshold for imager FG departure + + NAMELIST / Cloud_Detect_Coeffs / M__Sensor, N__Num_Bands, & + N__Band_Size, N__Bands, N__Window_Width, N__Window_Bounds, & + N__GradChkInterval, R__BT_Threshold, R__Grad_Threshold, & + R__Window_Grad_Threshold, L__Do_Quick_Exit, & + L__Do_CrossBand, N__BandToUse, & + L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, & + N__Num_Imager_Clusters, N__Imager_Chans, & + R__Stddev_Threshold, R__Coverage_Threshold, & + R__FG_Departure_Threshold + + !EOC !--------------------------------------------------------------------------- @@ -1749,6 +1799,7 @@ subroutine gsimain_initialize call set_fgrid2agrid call gsi_nstcoupler_init_nml call init_radaruse_directDA + call CADS_Setup_Cloud if(mype==0) write(6,*)' at 0 in gsimod, use_gfs_stratosphere,nems_nmmb_regional = ', & use_gfs_stratosphere,nems_nmmb_regional diff --git a/src/gsi/qcmod.f90 b/src/gsi/qcmod.f90 index 7146ceff3e..9804965573 100644 --- a/src/gsi/qcmod.f90 +++ b/src/gsi/qcmod.f90 @@ -115,6 +115,9 @@ module qcmod ! def vadfile - local name of bufr file containing vad winds (used by read_radar) ! def use_poq7 - if true, accept sbuv/2 obs with profile ozone quality flag 7 ! def cao_check - if true, turn on cold-air-outbreak screening +! def airs_cads - if true, use the cloud and aerosol detection routine for Aqua/AIRS instrument +! def cris_cads - if true, use the cloud and aerosol detection routine for CrIS instruments +! def iasi_cads - if true, use the cloud and aerosol detection routine for IASI instruments ! ! following used for nonlinear qc: ! @@ -152,7 +155,7 @@ module qcmod use constants, only: r0_01,r0_02,r0_03,r0_04,r0_05,r10,r60,r100,h300,r400,r1000,r2000,r2400,r4000 use constants, only: deg2rad,rad2deg,t0c,one_tenth,rearth_equator use obsmod, only: rmiss_single - use radinfo, only: iuse_rad,passive_bc + use radinfo, only: iuse_rad,passive_bc,nuchan use radinfo, only: tzr_qc use radiance_mod, only: rad_obs_type implicit none @@ -183,6 +186,7 @@ module qcmod public :: qc_gmi public :: qc_amsr2 public :: qc_saphir + ! set passed variables to public 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,gps_jacqc @@ -200,6 +204,7 @@ module qcmod public :: troflg public :: lat_c public :: nrand + public :: airs_cads, cris_cads, iasi_cads logical nlnqc_iter,njqc,vqc,nvqc,hub_norm logical noiqc @@ -215,6 +220,7 @@ module qcmod logical vadwnd_l2rw_qc logical troflg logical cao_check + logical airs_cads, cris_cads, iasi_cads character(10):: vadfile integer(i_kind) npres_print @@ -455,6 +461,10 @@ subroutine init_qcvars lat_c=21.0_r_kind nrand=13 + airs_cads = .false. + cris_cads = .false. + iasi_cads = .false. + return end subroutine init_qcvars @@ -2065,10 +2075,11 @@ subroutine qc_saphir(nchanl,sfchgt,luse,sea, & return end subroutine qc_saphir -subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & - cris, hirs, zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & - wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & - id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole) +subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr,airs, & + cris,iasi,hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & + wavenumber,ptau5,prsltmp,tvp,temp,wmix,chan_level,emissivity_k,ts,tsim, & + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole,cluster_fraction, & + cluster_bt, chan_stdev, model_bt) ! id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole,radmod) ! all-sky !$$$ subprogram documentation block @@ -2108,6 +2119,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! tzbgr - Tz over water ! tsavg5 - surface skin temperature ! tbc - simulated - observed BT with bias correction +! tsim - simulated BT ! tb_obs - observed Brightness temperatures ! tnoise - channel noise array ! wavenumber - array of channel wavenumbers @@ -2133,6 +2145,10 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! cld - cloud fraction ! cldp - cloud pressure ! zero_irjaco3_pole - logical to control use of ozone jacobians near poles +! cluster_fraction - size of imager derived cluster to determine clear cloudy profiles, used by CADS +! cluster_bt - imager brightness temperature of each cluster, used by CADS +! chan_stdev - standard deviation of cluster mean temperatures, used by CADS +! model_bt _ brightness temperature derived from the model's clear profile. used by CADS ! ! attributes: ! language: f90 @@ -2142,11 +2158,13 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & use kinds, only: r_kind, i_kind use radinfo, only: iomg_det, itopo_det, isst_det + use crtm_planck_functions, only: crtm_planck_radiance + use cads, only: cloud_aerosol_detection implicit none ! Declare passed variables - logical, intent(in ) :: sea,land,ice,snow,luse,goessndr, cris, hirs + logical, intent(in ) :: sea,land,ice,snow,luse,goessndr,airs,cris,hirs,iasi logical, intent(inout) :: zero_irjaco3_pole integer(i_kind), intent(in ) :: nsig,nchanl,ndat,is integer(i_kind),dimension(nchanl), intent(in ) :: ich @@ -2157,10 +2175,14 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & real(r_kind), intent( out) :: cld,cldp real(r_kind),dimension(40,ndat), intent(inout) :: aivals real(r_kind),dimension(nchanl), intent(in ) :: tbc,emissivity_k,ts,wavenumber,tb_obs,tbcnob - real(r_kind),dimension(nchanl), intent(in ) :: tnoise + real(r_kind),dimension(nchanl), intent(in ) :: chan_level + real(r_kind),dimension(nchanl), intent(in ) :: tnoise,tsim real(r_kind),dimension(nsig,nchanl),intent(in ) :: ptau5,temp,wmix real(r_kind),dimension(nsig), intent(in ) :: prsltmp,tvp real(r_kind),dimension(nchanl), intent(inout) :: errf,varinv,varinv_use + real(r_kind),dimension(7), intent(in ) :: cluster_fraction + real(r_kind),dimension(2,7), intent(in ) :: cluster_bt + real(r_kind),dimension(2), intent(in ) :: chan_stdev, model_bt ! Declare local parameters @@ -2168,21 +2190,29 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & real(r_kind) :: demisf,dtempf,efact,dtbf,term,cenlatx,sfchgtfact - real(r_kind) :: sum,sum2,sum3,cloudp,tmp,dts,delta - real(r_kind),dimension(nchanl) :: dtb - integer(i_kind) :: i,j,k,kk,lcloud,m + real(r_kind) :: sum1,sum2,sum3,tmp,dts,delta + integer(i_kind) :: i,j,lcloud,m,isurface_chan integer(i_kind), dimension(nchanl) :: irday real(r_kind) :: dtz,ts_ave,xindx,tzchks real(r_kind),parameter:: tbmax = 550._r_kind real(r_kind),parameter:: tbmin = 50._r_kind +! for cloud_aerosol_detect + integer(i_kind) :: I_Sensor_ID + integer(i_kind),dimension(nchanl) :: chan_array, i_flag_cloud + integer(i_kind),dimension(2) :: imager_chans + integer(i_kind) :: boundary_layer_pres, tropopause_height + integer(i_kind) :: ichan_10_micron, ichan_12_micron + real(r_kind),dimension(nchanl) :: tb_bc + real(r_kind) :: cloud_temperature, radiance_chan, radiance_model, radiance_cloud + real(r_kind) :: tb_obs_10, tb_obs_12, tb_obs_diff ! Reduce weight given to obs for shortwave ir if ! solar zenith angle tiny_r_kind irday = 1 if (pangs <= 89.0_r_kind .and. frac_sea > zero) then ! QC2 in statsrad - if(luse)aivals(9,is) = aivals(9,is) + one + if(luse) aivals(9,is) = aivals(9,is) + one do i=1,nchanl if(wavenumber(i) > r2000)then if(wavenumber(i) > r2400)then @@ -2225,7 +2255,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! If GOES and lza > 60. do not use if( goessndr .and. zasat*rad2deg > r60) then ! QC5 in statsrad - if(luse)aivals(12,is) = aivals(12,is) + one + if(luse) aivals(12,is) = aivals(12,is) + one do i=1,nchanl varinv(i) = zero varinv_use(i)=zero @@ -2237,7 +2267,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & sfchgtfact=one if (zsges > r2000) then ! QC1 in statsrad - if(luse)aivals(8,is) = aivals(8,is) + one + if(luse) aivals(8,is) = aivals(8,is) + one sfchgtfact = (r2000/zsges)**4 endif @@ -2265,114 +2295,196 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & cld=zero cldp=r10*prsltmp(1) - do k=1,nsig - if(prsltmp(k) > trop5)then - do i=1,nchanl - dtb(i)=(tvp(k)-tsavg5)*ts(i) - end do - do kk=1,k-1 - do i=1,nchanl - dtb(i)=dtb(i)+(tvp(k)-tvp(kk))*temp(kk,i) - end do - end do - sum=zero - sum2=zero - do i=1,nchanl - if(varinv_use(i) > tiny_r_kind)then - sum=sum+tbc(i)*dtb(i)*varinv_use(i) - sum2=sum2+dtb(i)*dtb(i)*varinv_use(i) - end if - end do - if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) - cloudp=min(max(sum/sum2,zero),one) - sum=zero - do i=1,nchanl - if(varinv_use(i) > tiny_r_kind)then - tmp=tbc(i)-cloudp*dtb(i) - sum=sum+tmp*tmp*varinv_use(i) - end if - end do - if(sum < sum3)then - sum3=sum - lcloud=k - cld=cloudp - cldp=r10*prsltmp(k) - end if - end if +! Cloud and aerosol detection routines (ECMWF) + if (cris .and. cris_cads) then + I_Sensor_ID = 27 + chan_array = nuchan(ich) ! channel numbers + tb_bc = tbc + tsim ! observation BT with bias correction + boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure + tropopause_height = nint(trop5) + imager_chans = (/15,16/) ! imager channel numbers (from satinfo) + isurface_chan = 501 ! surface channel + ichan_10_micron = 458 ! ~10.7 micron channel for low level cloud test + ichan_12_micron = 295 ! ~12.0 micron channel for low level cloud test + + call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, & + tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, & + cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp ) + + elseif ( iasi .and. iasi_cads ) then + I_Sensor_ID = 16 + chan_array = nuchan(ich) ! channel numbers + tb_bc = tbc + tsim ! observation BT with bias correction + boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure + tropopause_height = nint(trop5) + imager_chans = (/2,3/) ! imager channel numbers (from satinfo) + isurface_chan = 1271 ! surface channel + ichan_10_micron = 1173 ! ~10.7 micron channel for low level cloud test + ichan_12_micron = 756 ! ~12.0 micron channel for low level cloud test + + call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, & + tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, & + cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp ) + + elseif ( airs .and. airs_cads ) then + I_Sensor_ID = 11 + chan_array = nuchan(ich) ! channel numbers + tb_bc = tbc + tsim ! observation BT with bias correction + boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure + tropopause_height = nint(trop5) + isurface_chan = 914 ! surface channel + imager_chans = (/0,0/) ! imager channel numbers (from satinfo) + ichan_10_micron = 843 ! ~10.7 micron channel for low level cloud test + ichan_12_micron = 587 ! ~12.0 micron channel for low level cloud test + + call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, & + tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, & + cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp ) - end do - if ( lcloud > 0 ) then ! If cloud detected, reject channels affected by it. + else + call emc_legacy_cloud_detect(nchanl,nsig,tsavg5,trop5,prsltmp,tvp,ts,tbc,temp,varinv_use,lcloud,cld,cldp) - do i=1,nchanl + endif ! end of which cloud test to use +! compute cloud stats +! If using CADS + if ((cris .and. cris_cads) .or. (iasi .and. iasi_cads) .or. (airs .and. airs_cads)) then + +! Reject channels affected by clouds + do i=1, nchanl + if ( i_flag_cloud(i) == 1) then +! QC4 in statsrad + if(luse) aivals(11,is) = aivals(11,is) + one + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc + endif + end do + +! Derive cloud amount for CADS + cld = zero + if ( cldp < prsltmp(1) ) then ! if cloud in this profile exists + cloud_layer: do i=2, nsig ! determine which layer the cloud exists. + if (prsltmp(i) < cldp) then + lcloud = i + do j=1, nchanl ! use surface channel to derive cloud amount + m = nuchan(ich(j)) + if ( m == isurface_chan ) then ! interpolate cloud top temperature + cloud_temperature = ((tvp(lcloud) -tvp(lcloud -1)/ log(prsltmp(lcloud) / prsltmp(lcloud - 1))) & + * log(cldp/prsltmp(lcloud-1))) + tvp(lcloud-1) + call crtm_planck_radiance(1,m,tb_bc(j),radiance_chan) ! observation radiance. same as tb_obs + bias correction + call crtm_planck_radiance(1,m,tsim(j),radiance_model) ! model derived radiance + call crtm_planck_radiance(1,m,cloud_temperature,radiance_cloud) ! cloud top temperature radiance + cld = (radiance_chan - radiance_model) / (radiance_cloud - radiance_model) + cld = min(max(cld,zero),one) + cldp = cldp * r10 + exit cloud_layer ! cloud layer foound and cloud amount computed + endif ! surface channel found + end do !surface_chan + endif ! cloud found (prsltmp(i) < cldp) + end do cloud_layer + +! If clear, do a 10.7 - 12 micron test for low level clouds + else ! lcloud = 0 + do i=1, nchanl + if ( nuchan(ich(i)) == ichan_10_micron ) tb_obs_10 = tb_obs(i) + if ( nuchan(ich(i)) == ichan_12_micron ) tb_obs_12 = tb_obs(i) + end do + if ( tb_obs_10 > zero .and. tb_obs_12 > zero ) then + tb_obs_diff = tb_obs_10 - tb_obs_12 + if ( tb_obs_diff > 2.20_r_kind ) then ! Assume a cloud exists + cldp = prsltmp(1) * r10 ! Assume near surface cloud + cld = one ! Assume overcast cloud + lcloud = 1 + endif + endif + endif + +! If more than 2% of the transmittance comes from the cloud layer, reject the channel (0.02 is a tunable parameter). +! or CADS flagged a channel to have cloud. + if ( lcloud > 0 ) then + do i=1, nchanl + if ( ptau5(lcloud,i) > 0.02_r_kind ) then + if(luse) aivals(11,is) = aivals(11,is) + one ! QC4 in statsrad + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc + end if + end do + endif + +! default compute cloud stats, emc_legacy_cloud_detect + else + if ( lcloud > 0 ) then + + do i=1,nchanl ! reject channels with iuse_rad(j)=-1 when they are peaking below the cloud j=ich(i) if (passive_bc .and. iuse_rad(j)==-1) then - if (lcloud .ge. kmax(i)) then - if(luse)aivals(11,is) = aivals(11,is) + one - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc - cycle - end if + if (lcloud .ge. kmax(i)) then + if(luse)aivals(11,is) = aivals(11,is) + one + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc + cycle + end if end if ! If more than 2% of the transmittance comes from the cloud layer, ! reject the channel (0.02 is a tunable parameter) if ( ptau5(lcloud,i) > 0.02_r_kind) then -! QC4 in statsrad - if(luse)aivals(11,is) = aivals(11,is) + one - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc +! QC4 in statsrad + if(luse) aivals(11,is) = aivals(11,is) + one + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc end if - end do - -! If no clouds check surface temperature/emissivity + end do - else ! If no cloud was detected, do surface temp/emiss checks - sum=zero - sum2=zero - do i=1,nchanl + else ! surface consistency and sensitivity chacks. ( if lcoud = 0 ) + sum1=zero + sum2=zero + do i=1,nchanl if ( varinv_use(i) > tiny_r_kind .and. ts(i) > 0.0001_r_kind) then - sum=sum+tbc(i)*ts(i)*varinv_use(i) - sum2=sum2+ts(i)*ts(i)*varinv_use(i) + sum1 = sum1 +tbc(i)*ts(i)*varinv_use(i) + sum2 = sum2+ts(i)*ts(i)*varinv_use(i) endif - end do - if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) - dts=abs(sum/sum2) - if(abs(dts) > one)then + end do + if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) + dts=abs(sum1/sum2) + if(abs(dts) > one)then if(.not. sea)then - dts=min(dtempf,dts) + dts=min(dtempf,dts) else - dts=min(three,dts) + dts=min(three,dts) end if do i=1,nchanl - delta=max(r0_05*tnoise(i),r0_02) - if(abs(dts*ts(i)) > delta)then -! QC3 in statsrad - if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc - end if - end do - end if - endif + delta=max(r0_05*tnoise(i),r0_02) + if(abs(dts*ts(i)) > delta)then +! QC3 in statsrad + if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc + endif + enddo + endif + endif -! ! Temporary additional check for CrIS to reduce influence of land points on window channels (particularly important for bias correction) -! - if (cris .and. .not. sea) then - do i=1,nchanl - if (ts(i) > 0.2_r_kind) then + if (cris .and. .not. sea) then + do i=1,nchanl + if (ts(i) > 0.2_r_kind) then ! QC3 in statsrad - if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc - end if - end do - end if - + if(luse .and. varinv(i) > zero) & + aivals(10,is) = aivals(10,is) + one + varinv(i) = zero + if(id_qc(i) == igood_qc) id_qc(i) = ifail_sfcir_qc + end if + end do + end if + endif ! derive cloud stats ! ! Apply Tz retrieval ! @@ -2402,7 +2514,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & cenlatx=abs(cenlat)*r0_04 if (cenlatx < one) then - if(luse)aivals(6,is) = aivals(6,is) + one + if(luse) aivals(6,is) = aivals(6,is) + one efact = half*(cenlatx+one) do i=1,nchanl if(varinv(i) > tiny_r_kind) errf(i)=efact*errf(i) @@ -2414,7 +2526,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & 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) + if(term > tiny_r_kind) varinv(i) = varinv(i)/(one+varinv(i)*term) end if end do @@ -2497,12 +2609,113 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & endif !! if (hirs) !---mkim + return +end subroutine qc_irsnd +subroutine emc_legacy_cloud_detect(nchanl,nsig,tsavg5,trop5,prsltmp,tvp,ts,tbc,temp,varinv_use,lcloud,cld,cldp) + +!$$$ subprogram documentation block +! . . . +! subprogram: emc_legacy_cloud_detect determine clear/cloudy profiles from hirs,goessndr,airs,iasi,cris instruments +! +! prgmmr: derber ??? org: np23 date: ??? +! +! abstract: determine if a profile is clear/cloudy. If cloudy, determine model layer of the lcoud. +! This subroutine is designed for infrared sounders. +! +! program history log: +! 2022-06-20 jung moved into a subroutine +! +! input argument list: +! nchanl - number of channels per obs +! nsig - number of model layers +! tsavg5 - surface skin temperature +! trop5 - tropopause pressure +! prsltmp - array of layer pressure in vertical (surface to toa) +! tvp - array of temperatures in vertical (surface to toa) +! ts - skin temperature sensitivity +! tbc - simulated - observed BT with bias correction +! temp - temperature sensitivity array +! varinv_use - observation weight used (modified obs var error inverse) +! +! output argument list: +! lcloud - model layer of cloud +! cld - derived cloud amount +! cldp - model layer pressure (hPa) of cloud +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + +use kinds, only: i_kind, r_kind +use constants, only: tiny_r_kind, zero, r10 +implicit none + +integer(i_kind), intent(in ) :: nchanl, nsig +integer(i_kind), intent( out) :: lcloud +real(r_kind), intent(in ) :: tsavg5, trop5 +real(r_kind), intent( out) :: cld, cldp +real(r_kind), dimension(nchanl), intent(in ) :: tbc, ts, varinv_use +real(r_kind), dimension(nsig,nchanl), intent(in ) :: temp +real(r_kind), dimension(nsig), intent(in ) :: tvp, prsltmp + +integer(i_kind) :: i, k, kk + +real(r_kind) :: sum,sum2,sum3,cloudp,tmp +real(r_kind),dimension(nchanl) :: dtb + + sum3=zero + do i=1,nchanl + sum3=sum3+tbc(i)*tbc(i)*varinv_use(i) + end do + sum3=0.75_r_kind*sum3 + lcloud=0 + cld=zero + cldp=r10*prsltmp(1) + + do k=1,nsig + if(prsltmp(k) > trop5)then + do i=1,nchanl + dtb(i)=(tvp(k)-tsavg5)*ts(i) + end do + do kk=1,k-1 + do i=1,nchanl + dtb(i)=dtb(i)+(tvp(k)-tvp(kk))*temp(kk,i) + end do + end do + sum=zero + sum2=zero + do i=1,nchanl + if(varinv_use(i) > tiny_r_kind)then + sum=sum+tbc(i)*dtb(i)*varinv_use(i) + sum2=sum2+dtb(i)*dtb(i)*varinv_use(i) + end if + end do + if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) + cloudp=min(max(sum/sum2,zero),one) + sum=zero + do i=1,nchanl + if(varinv_use(i) > tiny_r_kind)then + tmp=tbc(i)-cloudp*dtb(i) + sum=sum+tmp*tmp*varinv_use(i) + end if + end do + if(sum < sum3)then + sum3=sum + lcloud=k + cld=cloudp + cldp=r10*prsltmp(k) + end if + end if + + end do + +end subroutine emc_legacy_cloud_detect - return -end subroutine qc_irsnd subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & zsges,cenlat,frac_sea,pangs,trop5,tzbgr,tsavg5,tbc,tb_obs,tnoise, & @@ -2593,7 +2806,6 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & real(r_kind),parameter:: oneover400=1.0_r_kind/400.0_r_kind - real(r_kind) :: demisf,dtempf,efact,dtbf,term,cenlatx,sfchgtfact real(r_kind) :: sum1,sum2,sum3,cloudp,tmp,dts real(r_kind),dimension(nchanl,nsig) :: dtb @@ -4304,7 +4516,7 @@ subroutine qc_geocsr(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 - integer(i_kind),dimension(nchanl), intent(in ) :: kmax + integer(i_kind),dimension(nchanl),intent(in ) :: kmax real(r_kind), intent(in ) :: zsges real(r_kind), intent(in ) :: tzbgr real(r_kind),dimension(40,ndat), intent(inout) :: aivals diff --git a/src/gsi/read_airs.f90 b/src/gsi/read_airs.f90 index 8dd22ffd5e..c5392dad14 100644 --- a/src/gsi/read_airs.f90 +++ b/src/gsi/read_airs.f90 @@ -622,7 +622,6 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& end do bufr_chans end if - ! Channel based quality control if(amsua)then diff --git a/src/gsi/read_cris.f90 b/src/gsi/read_cris.f90 index 9843f919d7..b8bf4ff92b 100644 --- a/src/gsi/read_cris.f90 +++ b/src/gsi/read_cris.f90 @@ -93,6 +93,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth,gsi_nstcoupler_deter use mpimod, only: npe use gsi_io, only: verbose + use qcmod, only: cris_cads ! use radiance_mod, only: rad_obs_type implicit none @@ -145,7 +146,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& character(len=40) :: infile2 integer(i_kind) :: kidsat, ksatid integer(i_kind) :: iret,ireadsb,ireadmg,irec,next, nrec_startx - integer(i_kind) :: bufr_nchan,maxinfo + integer(i_kind) :: bufr_nchan,maxinfo,dval_info integer(i_kind),allocatable,dimension(:)::nrec @@ -178,8 +179,8 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& logical :: outside,iuse,assim,valid,clear logical :: cris,quiet - integer(i_kind) :: ifov, ifor, iscn, instr, ioff, ilat, ilon, sensorindex - integer(i_kind) :: i, l, iskip, bad_line, llll + integer(i_kind) :: ifov, ifor, iscn, instr, ioff, ilat, ilon, sensorindex_cris + integer(i_kind) :: i, j, l, iskip, bad_line, llll integer(i_kind) :: nreal, isflg integer(i_kind) :: itx, k, nele, itt, n integer(i_kind):: idomsfc(1) @@ -187,7 +188,23 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& integer(i_kind):: error_status, irecx,ierr integer(i_kind):: radedge_min, radedge_max integer(i_kind):: bufr_size - character(len=20),dimension(1):: sensorlist + character(len=20),allocatable,dimension(:) :: sensorlist + +! Imager cluster information for CADS + integer(i_kind) :: iexponent, sensorindex_imager, cads_info + integer(i_kind),dimension(7) :: imager_cluster_index + logical :: imager_coeff + logical,dimension(7) :: imager_cluster_flag + character(len=80) :: spc_filename + character(len=20) :: sensorlist_imager + real(r_kind),dimension(83,7) :: imager_info + real(r_kind),dimension(7) :: imager_cluster_size + real(r_kind),dimension(2) :: imager_mean, imager_std_dev, imager_conversion + real(r_kind) :: imager_cluster_tot + +! bufr error codes +! real(r_kind),dimension(7,3) :: error_codes + ! scan angle calculation geometry based on: ! C. Root 2014: JPSS Ground Project Code 474-00032 @@ -209,6 +226,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! Set standard parameters character(8),parameter:: fov_flag="crosstrk" integer(i_kind),parameter:: sfc_channel=501 !used in thinning routine if cloud informatino is not available + integer(i_kind),parameter:: band_2_start=714 !for CADS, if any of band 1 (chans 1 - 713) are missing, reject profile integer(i_kind),parameter:: ichan=-999 ! fov-based surface code is not channel specific for cris real(r_kind),parameter:: expansion=one ! exansion factor for fov-based surface code. ! use one for ir sensors. @@ -227,8 +245,12 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& maxinfo = 31 disterrmax=zero ntest=0 - if(dval_use) maxinfo = maxinfo + 2 - nreal = maxinfo + nstinfo + dval_info = 0 + if(dval_use) dval_info = 2 + cads_info = 0 + if(cris_cads) cads_info = 23 + nreal = maxinfo + cads_info + dval_info + nstinfo + ndata = 0 nodata = 0 cris= obstype == 'cris' .or. obstype == 'cris-fsr' @@ -301,46 +323,89 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& 'SAID YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH SAZA BEARAZ SOZA SOLAZI' ! Load spectral coefficient structure - sensorlist(1)=sis quiet=.not. verbose + + imager_coeff = .false. +!TODO spc_filename = trim(crtm_coeffs_path)//'viirs-m_'//trim(jsatid)//'.SpcCoeff.bin' ! when viirs naming convention becomes standarized + if ( trim(jsatid) == 'npp' ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_npp.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_npp' + elseif ( trim(jsatid) == 'n20' ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_n20.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_n20' + inquire(file=trim(spc_filename), exist=imager_coeff) + if ( .not. imager_coeff ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j1.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_j1' + elseif ( trim(jsatid) == 'n21' ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_n21.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_n21' + inquire(file=trim(spc_filename), exist=imager_coeff) + if ( .not. imager_coeff ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j2.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_j2' + endif + inquire(file=trim(spc_filename), exist=imager_coeff) + if ( imager_coeff ) then + allocate( sensorlist(2)) + sensorlist(1) = sis +!TODO sensorlist(2) = 'viirs-m_'//trim(jsatid) !when viirs naming conventions becomes standardized + sensorlist(2) = trim(sensorlist_imager) + else + allocate( sensorlist(1)) + sensorlist(1) = sis + endif + if( crtm_coeffs_path /= "" ) then if(mype_sub==mype_root .and. print_verbose) write(6,*)'READ_CRIS: crtm_spccoeff_load() on path "'//trim(crtm_coeffs_path)//'"' error_status = crtm_spccoeff_load(sensorlist,& - File_Path = crtm_coeffs_path,quiet=quiet ) + File_Path = crtm_coeffs_path,quiet=quiet) else error_status = crtm_spccoeff_load(sensorlist,quiet=quiet) endif if (error_status /= success) then write(6,*)'READ_CRIS: ***ERROR*** crtm_spccoeff_load error_status=',error_status,& - ' TERMINATE PROGRAM EXECUTION' + ' TERMINATE PROGRAM EXECUTION' call stop2(71) endif +! find CRIS sensorindex. + sensorindex_cris = 0 + if ( sc(1)%sensor_id(1:4) == 'cris' )then + sensorindex_cris = 1 + else + write(6,*)'READ_CRIS: ***ERROR*** sensorindex_cris not set NO CRIS DATA USED' + write(6,*)'READ_CRIS: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION' + call stop2(71) + end if + +! find imager sensorindex. + sensorindex_imager = 0 + if ( cris_cads .and. imager_coeff ) then + if ( sc(2)%sensor_id(1:4) == 'viir' )then + sensorindex_imager = 2 + else + write(6,*)'READ_CRIS: ***ERROR*** sensorindex_viirs not set NO VIIRS CLUSTER INFO USED BY CADS' + write(6,*)'READ_CRIS: We are looking for ', sc(2)%sensor_id, ' TERMINATE PROGRAM EXECUTION' + imager_coeff = .false. + end if + else + imager_coeff = .false. + end if + ! Find the channels being used (from satinfo file) in the spectral coef. structure. do i=subset_start,subset_end channel_number(i -subset_start +1) = nuchan(i) end do sc_index(:) = 0 satinfo_chan: do i=1,satinfo_nchan - spec_coef: do l=1,sc(1)%n_channels - if ( channel_number(i) == sc(1)%sensor_channel(l) ) then + spec_coef: do l=1,sc(sensorindex_cris)%n_channels + if ( channel_number(i) == sc(sensorindex_cris)%sensor_channel(l) ) then sc_index(i) = l exit spec_coef endif end do spec_coef end do satinfo_chan -! find CRIS sensorindex. - sensorindex = 0 - if ( sc(1)%sensor_id(1:4) == 'cris' )then - sensorindex = 1 - else - write(6,*)'READ_CRIS: ***ERROR*** sensorindex not set NO CRIS DATA USED' - write(6,*)'READ_CRIS: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION' - call stop2(71) - end if - ! Calculate parameters needed for FOV-based surface calculation. if (isfcalc==1)then instr=17 ! CrIS is similar to AIRS for this purpose. @@ -687,7 +752,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& clear = .false. pred = zero -! Cloud information may be missing depending on how the VIIRS granules align +! Cloud information may be missing depending on how the imager granules align ! with the CrIS granules. ! Cloud Amount, TOCC is total cloud cover [%], HOCT is cloud height [m] call ufbint(lnbufr,cloud_properties,2,1,iret,'TOCC HOCT') @@ -699,7 +764,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& else pred1 = cloud_properties(2) *7.0_r_kind / r1000 ! Assume a lapse rate to convert hgt to delta TB. 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 + call crtm_planck_temperature(sensorindex_cris,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation pred2 = tsavg *0.98_r_kind - temperature(sfc_channel_index) pred = max(pred1,pred2) ! use the largest of lapse rate (pred1) or sfc channel-surface difference (pred2) endif @@ -709,7 +774,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! the surface channel is fixed and set earlier in the code (501). 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 + call crtm_planck_temperature(sensorindex_cris,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 clear = .true. @@ -743,7 +808,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! now such spectra are rejected. 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 + call crtm_planck_temperature(sensorindex_cris,sc_chan,radiance,temperature(bufr_chan)) ! radiance to BT calculation else ! error with channel number or radiance temperature(bufr_chan) = tbmin endif @@ -756,12 +821,12 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& bufr_chan = bufr_index(i) if(temperature(bufr_chan) <= tbmin .or. temperature(bufr_chan) >= tbmax ) then temperature(bufr_chan) = tbmin - if(iuse_rad(ioff+i) >= 0) iskip = iskip + 1 + if(iuse_rad(ioff+i) >= 0 .or. (cris_cads .and. sc_index(i) < band_2_start)) iskip = iskip + 1 endif end do skip_loop if(iskip > 0 .and. print_verbose)write(6,*) ' READ_CRIS : iskip > 0 ',iskip -! if( iskip >= 10 )cycle read_loop + if( iskip >= 10 .and. cris_cads ) cycle read_loop crit1=crit1 + ten*real(iskip,r_kind) @@ -772,9 +837,86 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& call finalcheck(one,crit1,itx,iuse) endif if(.not. iuse)cycle read_loop -! + +! Read the imager cluster information for the Cloud and Aerosol Detection Software. +! Only channels 15 and 16 are used. + + if ( cris_cads ) then + call ufbseq(lnbufr,imager_info,83,7,iret,'CRISCS') + if ( iret == 7 .and. imager_info(3,1) <= 100.0_r_kind .and. & + imager_info(3,1) >= zero .and. imager_coeff ) then ! if imager cluster info exists + imager_mean = zero + imager_std_dev = zero + imager_cluster_tot = zero + imager_cluster_flag = .TRUE. + imager_cluster_size = imager_info(3,1:7) + imager_cluster_size(:) = imager_cluster_size(:) / sum(imager_cluster_size(:)) + imager_conversion(1) = one / (sc(sensorindex_imager)%wavenumber(4) **2) + imager_conversion(2) = one / (sc(sensorindex_imager)%wavenumber(5) **2) + +! Order clusters from largest (1) to smallest (7) + imager_cluster_sort: do i=1,7 + j = maxloc(imager_cluster_size,dim=1,mask=imager_cluster_flag) + imager_cluster_index(i) = j + imager_cluster_flag(j) = .FALSE. + end do imager_cluster_sort + +! Convert from radiance to brightness temperature for mean and standard devation used by CADS +! Imager cluster info added to data_all array. + + imager_cluster_info: do j=1,7 + i = imager_cluster_index(j) + + data_all(maxinfo+j,itx) = imager_cluster_size(i) ! Imager cluster fraction + imager_cluster_tot = imager_cluster_tot + imager_info(3,i) + + iexponent = -(nint(imager_info(75,i)) -11) ! channel 15 radiance for each cluster + imager_info(76,i) = imager_info(76,i) * imager_conversion(1) * (ten ** iexponent) + + iexponent = -(nint(imager_info(77,i)) -11) ! channel 15 radiance std dev for each cluster. + imager_info(78,i) = imager_info(78,i) * imager_conversion(1) * (ten ** iexponent) + + call crtm_planck_temperature(sensorindex_imager,4,imager_info(76,i),data_all(maxinfo+7+j,itx)) + data_all(maxinfo+7+j,itx) = max(data_all(maxinfo+7+j,itx),zero) + + iexponent = -(nint(imager_info(80,i)) -11) ! channel 16 radiance for each cluster + imager_info(81,i) = imager_info(81,i) * imager_conversion(2) * (ten ** iexponent) + + iexponent = -(nint(imager_info(82,i))-5 ) ! channel 16 radiance std dev for each cluster. + iexponent = -(nint(imager_info(82,i)) -11) ! channel 16 radiance std dev for each cluster. + imager_info(83,i) = imager_info(83,i) * imager_conversion(2) * (ten ** iexponent) + + call crtm_planck_temperature(sensorindex_imager,5,imager_info(81,i),data_all(maxinfo+14+j,itx)) + data_all(maxinfo+14+j,itx) = max(data_all(maxinfo+14+j,itx),zero) + + + end do imager_cluster_info + +! Compute cluster averages for each channel + + imager_mean(1) = sum(imager_cluster_size(:) * imager_info(76,:)) ! Channel 15 radiance cluster average + imager_std_dev(1) = sum(imager_cluster_size(:) * (imager_info(76,:)**2 + imager_info(78,:)**2)) - imager_mean(1)**2 + imager_std_dev(1) = sqrt(max(imager_std_dev(1),zero)) ! Channel 15 radiance RMSE + call crtm_planck_temperature(sensorindex_imager,4,(imager_std_dev(1) + imager_mean(1)),imager_std_dev(1)) + call crtm_planck_temperature(sensorindex_imager,4,imager_mean(1),imager_mean(1)) ! Channel 15 average BT + imager_std_dev(1) = imager_std_dev(1) - imager_mean(1) ! Channel 15 BT std dev + data_all(maxinfo+22,itx) = imager_std_dev(1) + + imager_mean(2) = sum(imager_cluster_size(:) * imager_info(81,:)) ! Channel 16 radiance cluster average + imager_std_dev(2) = sum(imager_cluster_size(:) * (imager_info(81,:)**2 + imager_info(83,:)**2)) - imager_mean(1)**2 + imager_std_dev(2) = sqrt(max(imager_std_dev(1),zero)) ! Channel 16 radiance RMSE + call crtm_planck_temperature(sensorindex_imager,5,(imager_std_dev(2) + imager_mean(2)),imager_std_dev(2)) + call crtm_planck_temperature(sensorindex_imager,5,imager_mean(2),imager_mean(2)) ! Channel 16 average BT + imager_std_dev(2) = imager_std_dev(2) - imager_mean(2) ! Channel 16 BT std dev + data_all(maxinfo+23,itx) = imager_std_dev(2) + + else ! Imager cluster information is missing. Set everything to zero + data_all(maxinfo+1 : maxinfo+25,itx) = zero + endif + endif ! cris_cads + ! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr -! + if ( nst_gsi > 0 ) then tref = ts(0) dtw = zero @@ -818,15 +960,17 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees) if(dval_use) then - data_all(32,itx)= val_cris - data_all(33,itx)= itt + data_all(maxinfo+cads_info+1,itx)= val_cris + data_all(maxinfo+cads_info+2,itx)= itt +! data_all(32+cads_info,itx)= val_cris +! data_all(33+cads_info,itx)= itt end if if ( nst_gsi > 0 ) then - data_all(maxinfo+1,itx) = tref ! foundation temperature - data_all(maxinfo+2,itx) = dtw ! dt_warm at zob - data_all(maxinfo+3,itx) = dtc ! dt_cool at zob - data_all(maxinfo+4,itx) = tz_tr ! d(Tz)/d(Tr) + data_all(maxinfo+cads_info+dval_info+1,itx) = tref ! foundation temperature + data_all(maxinfo+cads_info+dval_info+2,itx) = dtw ! dt_warm at zob + data_all(maxinfo+cads_info+dval_info+3,itx) = dtc ! dt_cool at zob + data_all(maxinfo+cads_info+dval_info+4,itx) = tz_tr ! d(Tz)/d(Tr) endif ! Put satinfo defined channel temperatures into data array diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index 9ab1d5446f..edd7a9b50e 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -127,6 +127,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter use mpimod, only: npe use gsi_io, only: verbose + use qcmod, only: iasi_cads ! use radiance_mod, only: rad_obs_type implicit none @@ -208,11 +209,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& logical :: outside,iuse,assim,valid logical :: iasi,quiet,cloud_info - integer(i_kind) :: ifov, instr, iscn, ioff, sensorindex + integer(i_kind) :: ifov, instr, iscn, ioff, sensorindex_iasi integer(i_kind) :: i, j, l, iskip, ifovn, bad_line, ksatid, kidsat, llll integer(i_kind) :: nreal, isflg integer(i_kind) :: itx, k, nele, itt, n - integer(i_kind):: iexponent,maxinfo, bufr_nchan + integer(i_kind):: iexponent,maxinfo, bufr_nchan, dval_info integer(i_kind):: idomsfc(1) integer(i_kind):: ntest integer(i_kind):: error_status, irecx,ierr @@ -221,8 +222,18 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& integer(i_kind) :: sfc_channel_index integer(i_kind),allocatable, dimension(:) :: channel_number, sc_index, bufr_index integer(i_kind),allocatable, dimension(:) :: bufr_chan_test - character(len=20),dimension(1):: sensorlist - + character(len=20),allocatable, dimension(:):: sensorlist + +! Imager clouser information for CADS + integer(i_kind) :: sensorindex_imager, cads_info + integer(i_kind),dimension(7) :: imager_cluster_index + logical :: imager_coeff + logical,dimension(7) :: imager_cluster_flag + character(len=80) :: spc_filename + real(r_kind),dimension(33,7) :: imager_info + real(r_kind),dimension(7) :: imager_cluster_size + real(r_kind),dimension(2) :: imager_mean, imager_std_dev + real(r_kind) :: imager_cluster_tot ! Set standard parameters character(8),parameter:: fov_flag="crosstrk" @@ -248,8 +259,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& maxinfo = 31 disterrmax=zero ntest=0 - if(dval_use) maxinfo=maxinfo+2 - nreal = maxinfo + nstinfo + dval_info = 0 + if(dval_use) dval_info = 2 + cads_info = 0 + if(iasi_cads) cads_info = 23 + nreal = maxinfo + cads_info + dval_info + nstinfo ndata = 0 nodata = 0 @@ -315,7 +329,19 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! load spectral coefficient structure quiet=.not. verbose - sensorlist(1)=sis + + imager_coeff = .false. + spc_filename =trim(crtm_coeffs_path)//'avhrr3_'//trim(jsatid)//'.SpcCoeff.bin' + inquire(file=trim(spc_filename), exist=imager_coeff) + if ( imager_coeff ) then + allocate( sensorlist(2)) + sensorlist(1) = sis + sensorlist(2) = 'avhrr3_'//trim(jsatid) + else + allocate( sensorlist(1)) + sensorlist(1) = sis + endif + if( crtm_coeffs_path /= "" ) then if(mype_sub==mype_root .and. print_verbose) write(6,*)'READ_IASI: crtm_spccoeff_load() on path "'//trim(crtm_coeffs_path)//'"' error_status = crtm_spccoeff_load(sensorlist,& @@ -330,6 +356,31 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& call stop2(71) endif +! find IASI sensorindex + sensorindex_iasi = 0 + if ( sc(1)%sensor_id(1:4) == 'iasi' ) then + sensorindex_iasi = 1 + else + write(6,*)'READ_IASI: ***ERROR*** sensorindex_iasi not set NO IASI DATA USED' + write(6,*)'READ_IASI: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION' + call stop2(71) + end if + +! find imager sensorindex + sensorindex_imager = 0 + if ( iasi_cads .and. imager_coeff ) then + if ( sc(2)%sensor_id(1:4) == 'avhr' ) then + sensorindex_imager = 2 + imager_coeff = .true. + else + write(6,*)'READ_IASI: ***ERROR*** sensorindex_imager is not set NO IASI DATA USED' + write(6,*)'READ_IASI: We are looking for ', sc(2)%sensor_id + imager_coeff = .false. + end if + else + imager_coeff = .false. + end if + ! Find the channels being used (from satinfo file) in the spectral coef. structure. do i=subset_start,subset_end channel_number(i -subset_start +1) = nuchan(i) @@ -337,23 +388,13 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& sc_index(:) = 0 satinfo_chan: do i=1,satinfo_nchan spec_coef: do l=1,sc(1)%n_channels - if ( channel_number(i) == sc(1)%sensor_channel(l) ) then + if ( channel_number(i) == sc(sensorindex_iasi)%sensor_channel(l) ) then sc_index(i) = l exit spec_coef endif end do spec_coef end do satinfo_chan -! find IASI sensorindex - sensorindex = 0 - if ( sc(1)%sensor_id(1:4) == 'iasi' ) then - sensorindex = 1 - else - write(6,*)'READ_IASI: sensorindex not set NO IASI DATA USED' - write(6,*)'READ_IASI: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION' - call stop2(71) - end if - ! Calculate parameters needed for FOV-based surface calculation. if (isfcalc==1)then instr=18 @@ -725,7 +766,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds radiance = allchan(2,bufr_chan)*scalef(bufr_chan) sc_chan = sc_index(i) - call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) + call crtm_planck_temperature(sensorindex_iasi,sc_chan,radiance,temperature(bufr_chan)) else temperature(bufr_chan) = tbmin endif @@ -750,7 +791,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! crit1=crit1 + ten*real(iskip,r_kind) -! If the surface channel exists (~960.0 cm-1) and the AVHRR cloud information is missing, use an +! If the surface channel exists (~960.0 cm-1) and the imager cloud information is missing, use an ! estimate of the surface temperature to determine if the profile may be clear. if (.not. cloud_info) then pred = tsavg*0.98_r_kind - temperature(sfc_channel_index) @@ -766,6 +807,78 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& endif if(.not. iuse)cycle read_loop +! Read the imager cluster information for the Cloud and Aerosol Detection Software. +! Only channels 4 and 5 are used. + + if ( iasi_cads ) then + call ufbseq(lnbufr,imager_info,33,7,iret,'IASIL1CS') + if (iret == 7 .and. imager_info(3,1) <= 100.0_r_kind .and. & + imager_info(3,1) >= zero .and. imager_coeff ) then ! if imager cluster info exists + imager_mean = zero + imager_std_dev = zero + imager_cluster_tot = zero + imager_cluster_flag = .TRUE. + imager_cluster_size = imager_info(3,1:7) + imager_cluster_size(:) = imager_cluster_size(:) / sum(imager_cluster_size(:)) + +! Order clusters from largest (1) to smallest (7) + imager_cluster_sort: do i=1,7 + j = maxloc(imager_cluster_size,dim=1,mask=imager_cluster_flag) + imager_cluster_index(i) = j + imager_cluster_flag(j) = .FALSE. + end do imager_cluster_sort + +! Convert from radiance to brightness temperature for mean and standard deviation used by CADS. +! Imager cluster info added to data_all array + + imager_cluster_info: do j=1,7 + i = imager_cluster_index(j) + + data_all(maxinfo+j,itx) = imager_cluster_size(i) ! Imager cluster fraction + imager_cluster_tot = imager_cluster_tot + imager_info(3,i) + + iexponent = -(nint(imager_info(25,i))-5 ) ! channel 4 radiance for each cluster. + imager_info(26,i) = imager_info(26,i) * (ten ** iexponent) + + iexponent = -(nint(imager_info(27,i))-5 ) ! channel 4 radiance std dev for each cluster. + imager_info(28,i) = imager_info(28,i) * (ten ** iexponent) + + call crtm_planck_temperature(sensorindex_imager,2,imager_info(26,i),data_all(maxinfo+7+j,itx)) + data_all(maxinfo+7+j,itx) = max(data_all(maxinfo+7+j,itx),zero) + + iexponent = -(nint(imager_info(30,i))-5 ) ! channel 5 radiance for each cluster + imager_info(31,i) = imager_info(31,i) * (ten ** iexponent) + + iexponent = -(nint(imager_info(32,i))-5 ) ! channel 5 radiance std dev for each cluser. + imager_info(33,i) = imager_info(33,i) * (ten ** iexponent) + + call crtm_planck_temperature(sensorindex_imager,3,imager_info(31,i),data_all(maxinfo+14+j,itx)) + data_all(maxinfo+14+j,itx) = max(data_all(maxinfo+14+j,itx),zero) + + end do imager_cluster_info + +! Compute cluster averages for each channel + + imager_mean(1) = sum(imager_cluster_size(:) * imager_info(26,:)) ! Channel 4 radiance cluster average + imager_std_dev(1) = sum(imager_cluster_size(:) * (imager_info(26,:)**2 + imager_info(28,:)**2)) - imager_mean(1)**2 + imager_std_dev(1) = sqrt(max(imager_std_dev(1),zero)) ! Channel 4 radiance RMSE + call crtm_planck_temperature(sensorindex_imager,2,(imager_std_dev(1) + imager_mean(1)),imager_std_dev(1)) + call crtm_planck_temperature(sensorindex_imager,2,imager_mean(1),imager_mean(1)) ! Channel 4 average BT + imager_std_dev(1) = imager_std_dev(1) - imager_mean(1) ! Channel 4 BT std dev + data_all(maxinfo+22,itx) = imager_std_dev(1) + + imager_mean(2) = sum(imager_cluster_size(:) * imager_info(31,:)) ! Channel 5 radiance cluster average + imager_std_dev(2) = sum(imager_cluster_size(:) * (imager_info(31,:)**2 + imager_info(33,:)**2)) - imager_mean(1)**2 + imager_std_dev(2) = sqrt(max(imager_std_dev(1),zero)) ! Channel 5 radiance RMSE + call crtm_planck_temperature(sensorindex_imager,3,(imager_std_dev(2) + imager_mean(2)),imager_std_dev(2)) + call crtm_planck_temperature(sensorindex_imager,3,imager_mean(2),imager_mean(2)) ! Channel 5 average BT + imager_std_dev(2) = imager_std_dev(2) - imager_mean(2) ! Channel 5 BT std dev + data_all(maxinfo+23,itx) = imager_std_dev(2) + + else ! Imager cluster information is missing. Set everything to zero + data_all(maxinfo+1 : maxinfo+25,itx) = zero + endif + endif ! iasi_cads = .true. ! ! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr ! @@ -813,15 +926,15 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees) if(dval_use)then - data_all(32,itx)= val_iasi - data_all(33,itx)= itt + data_all(maxinfo+cads_info+1,itx)= val_iasi + data_all(maxinfo+cads_info+2,itx)= itt end if if ( nst_gsi > 0 ) then - data_all(maxinfo+1,itx) = tref ! foundation temperature - data_all(maxinfo+2,itx) = dtw ! dt_warm at zob - data_all(maxinfo+3,itx) = dtc ! dt_cool at zob - data_all(maxinfo+4,itx) = tz_tr ! d(Tz)/d(Tr) + data_all(maxinfo+cads_info+dval_info+1,itx) = tref ! foundation temperature + data_all(maxinfo+cads_info+dval_info+2,itx) = dtw ! dt_warm at zob + data_all(maxinfo+cads_info+dval_info+3,itx) = dtc ! dt_cool at zob + data_all(maxinfo+cads_info+dval_info+4,itx) = tz_tr ! d(Tz)/d(Tr) endif ! Put satinfo defined channel temperatures into data array diff --git a/src/gsi/setupaod.f90 b/src/gsi/setupaod.f90 index 58707acd6a..e0964ee972 100644 --- a/src/gsi/setupaod.f90 +++ b/src/gsi/setupaod.f90 @@ -180,6 +180,7 @@ subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,& real(r_kind) :: qcall, smask real(r_kind) :: styp, dbcf + real(r_kind),dimension(nchanl):: chan_level real(r_kind),dimension(nchanl):: emissivity,ts,emissivity_k real(r_kind),dimension(nchanl):: tsim real(r_kind),dimension(nsig,nchanl):: wmix,temp,ptau5 @@ -409,7 +410,7 @@ subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qsat,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & + tsim,emissivity,chan_level,ptau5,ts,emissivity_k, & temp,wmix,jacobian,error_status,layer_od=layer_od,jacobian_aero=jacobian_aero) ! interpolate aerosols at observation locations for diag files here if (aero_diagsave) then diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 20ab63456e..1ff2474e20 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -297,12 +297,14 @@ 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, optconv use qcmod, only: setup_tzr_qc,ifail_scanedge_qc,ifail_outside_range + use qcmod, only: iasi_cads, cris_cads 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 use sparsearr, only: sparr2, new, writearray, size, fullarray use radiance_mod, only: radiance_ex_obserr_gmi,radiance_ex_biascor_gmi + use cads, only: cads_imager_calc implicit none @@ -400,6 +402,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& real(r_kind),dimension(nsig):: qvp,tvp,qs real(r_kind),dimension(nsig):: prsltmp real(r_kind),dimension(nsig+1):: prsitmp + real(r_kind),dimension(nchanl):: chan_level real(r_kind),dimension(nchanl):: weightmax real(r_kind),dimension(nchanl):: cld_rbc_idx,cld_rbc_idx2 real(r_kind),dimension(nchanl):: tcc @@ -440,6 +443,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& logical:: muse_ii +! variables added for CADS + real(r_kind),dimension(7,nobs) :: imager_cluster_fraction + real(r_kind),dimension(2,7,nobs) :: imager_cluster_bt + real(r_kind),dimension(2,nobs) :: imager_chan_stdev, imager_model_bt + ! Notations in use: for a single obs. or a single obs. type ! nchanl : a known channel count of a given type obs stream ! nchanl_diag : a subset of "iuse" @@ -591,6 +599,26 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& return endif +! Load data array for current satellite + read(lunin) data_s,luse,ioid + + if (nobskeep>0) then +! write(6,*)'setuprad: nobskeep',nobskeep + call stop2(275) + end if + + call dtime_setup() +! If using CADS setup arrays and calculate imager BTs + imager_cluster_fraction=zero + imager_cluster_bt=zero + imager_chan_stdev=zero + imager_model_bt=zero + if ((iasi_cads .and. iasi) .or. (cris_cads .and. cris)) then + + call cads_imager_calc(obstype,isis,nobs,nreal,nchanl,nsig,data_s,init_pass,mype, & + imager_cluster_fraction,imager_cluster_bt,imager_chan_stdev, imager_model_bt) + endif ! using cads + if ( mype == 0 .and. .not.l_may_be_passive) write(6,*)mype,'setuprad: passive obs',is,isis ! Logic to turn off print of reading coefficients if not first interation or not mype_diaghdr or not init_pass @@ -697,8 +725,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif endif - - ! Find number of channels written to diag file if(reduce_diag)then nchanl_diag=0 @@ -768,24 +794,9 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& if (netcdf_diag) call init_netcdf_diag_ endif -! Load data array for current satellite - read(lunin) data_s,luse,ioid - - if (nobskeep>0) then -! write(6,*)'setuprad: nobskeep',nobskeep - call stop2(275) - end if - - if (abi2km .and. regional) then - abi2km_bc = zero - abi2km_bc(2) = 233.5_r_kind - abi2km_bc(3) = 241.7_r_kind - abi2km_bc(4) = 250.5_r_kind - end if ! PROCESSING OF SATELLITE DATA ! Loop over data in this block - call dtime_setup() do n = 1,nobs ! Extract analysis relative observation time. dtime = data_s(itime,n) @@ -911,7 +922,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & + tsim,emissivity,chan_level,ptau5,ts,emissivity_k, & temp,wmix,jacobian,error_status,tsim_clr=tsim_clr,tcc=tcc, & tcwv=tcwv,hwp_ratio=hwp_ratio,stability=stability) if(gmi) then @@ -922,7 +933,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim2,emissivity2,ptau52,ts2,emissivity_k2, & + tsim2,emissivity2,chan_level,ptau52,ts2,emissivity_k2, & temp2,wmix2,jacobian2,error_status,tsim_clr=tsim_clr2,tcc=tcc,& tcwv=tcwv,hwp_ratio=hwp_ratio,stability=stability) ! merge @@ -946,7 +957,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & + tsim,emissivity,chan_level,ptau5,ts,emissivity_k, & temp,wmix,jacobian,error_status) if(gmi) then gmi_low_angles(1:3)=data_s(ilzen_ang:iscan_ang,n) @@ -956,7 +967,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim2,emissivity2,ptau52,ts2,emissivity_k2, & + tsim2,emissivity2,chan_level,ptau52,ts2,emissivity_k2, & temp2,wmix2,jacobian2,error_status) ! merge emissivity(10:13) = emissivity2(10:13) @@ -1091,6 +1102,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero + abi2km_bc = zero + abi2km_bc(2) = 233.5_r_kind + abi2km_bc(3) = 241.7_r_kind + abi2km_bc(4) = 250.5_r_kind + !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) @@ -1376,10 +1392,12 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& varinv_use(i) = zero end if end do - call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr, & - cris,hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & - wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & - id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole(n)) + + call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr,airs,cris,iasi, & + hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & + wavenumber,ptau5,prsltmp,tvp,temp,wmix,chan_level,emissivity_k,ts,tsim, & + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole(n), & + imager_cluster_fraction(:,n), imager_cluster_bt(:,:,n), imager_chan_stdev(:,n),imager_model_bt(:,n)) ! --------- MSU ------------------- ! QC MSU data @@ -2745,9 +2763,10 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) deallocate(predbias_angord) endif end subroutine contents_netcdf_diag_ - subroutine final_binary_diag_ close(4) end subroutine final_binary_diag_ end subroutine setuprad + + end module rad_setup From 44a8f59ef5cb6def27ba27fcc6a35c074a30332b Mon Sep 17 00:00:00 2001 From: Xu Lu Date: Tue, 5 Dec 2023 09:43:40 -0600 Subject: [PATCH 3/4] Dual-resolution EnVar capability for HAFS ensemble (#652) **Description** Add Dual-resolution EnVar capability for HAFS ensemble By Xu Lu and Xuguang Wang from OU. POC: xuguang.wang@ou.edu Fixes #603 **Type of change** - [Y] New feature (non-breaking change which adds functionality) **How Has This Been Tested?** Did a single observation test to ensure the capability works and the increments look reasonable compared to the single-resolution increment on Orion. **Checklist** - [Y] My code follows the style guidelines of this project - [Y] I have performed a self-review of my own code - [Y] I have commented my code, particularly in hard-to-understand areas - [Y] Any dependent changes have been merged and published **DUE DATE for this PR is 12/15/2023**. If this PR is not merged into `develop` by this date, the PR will be closed and returned to the developer. --------- Co-authored-by: Bin.Liu Co-authored-by: YongzuoLi-NOAA --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 17 +- src/gsi/gridmod.F90 | 6 +- src/gsi/gsi_rfv3io_mod.f90 | 345 +++++++++++-- src/gsi/hybrid_ensemble_isotropic.F90 | 11 +- src/gsi/mod_fv3_lola.f90 | 556 +++++++++++++++++++++ 5 files changed, 875 insertions(+), 60 deletions(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 2382ff1286..81fb684a73 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -38,6 +38,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) ! ! 2021-08-10 lei - modify for fv3-lam ensemble spread output ! 2021-11-01 lei - modify for fv3-lam parallel IO + ! 2022-03-01 X.Lu & X.Wang - modify for hafs dual ens. POC: xuguang.wang@ou.edu ! input argument list: ! ! output argument list: @@ -848,7 +849,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g 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 hybrid_ensemble_parameters, only: fv3sar_ensemble_opt,dual_res use mpimod, only: mpi_comm_world,mpi_rtype use gsi_rfv3io_mod,only: type_fv3regfilenameg @@ -956,24 +957,24 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g if(fv3sar_ensemble_opt == 0 ) then - call gsi_fv3ncdf_readuv(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput) + call gsi_fv3ncdf_readuv(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput,dual_res) else - call gsi_fv3ncdf_readuv_v1(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput) + call gsi_fv3ncdf_readuv_v1(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput,dual_res) endif if(fv3sar_ensemble_opt == 0) then call gsi_fv3ncdf_read(grd_fv3lam_ens_dynvar_io_nouv,gsibundle_fv3lam_ens_dynvar_nouv,& - fv3_filenameginput%dynvars,fv3_filenameginput) + fv3_filenameginput%dynvars,fv3_filenameginput,dual_res) call gsi_fv3ncdf_read(grd_fv3lam_ens_tracer_io_nouv,gsibundle_fv3lam_ens_tracer_nouv,& - fv3_filenameginput%tracers,fv3_filenameginput) + fv3_filenameginput%tracers,fv3_filenameginput,dual_res) if( if_model_dbz .or. if_model_fed ) then call gsi_fv3ncdf_read(grd_fv3lam_ens_phyvar_io_nouv,gsibundle_fv3lam_ens_phyvar_nouv,& - fv3_filenameginput%phyvars,fv3_filenameginput) + fv3_filenameginput%phyvars,fv3_filenameginput,dual_res) end if else call gsi_fv3ncdf_read_v1(grd_fv3lam_ens_dynvar_io_nouv,gsibundle_fv3lam_ens_dynvar_nouv,& - fv3_filenameginput%dynvars,fv3_filenameginput) + fv3_filenameginput%dynvars,fv3_filenameginput,dual_res) call gsi_fv3ncdf_read_v1(grd_fv3lam_ens_tracer_io_nouv,gsibundle_fv3lam_ens_tracer_nouv,& - fv3_filenameginput%tracers,fv3_filenameginput) + fv3_filenameginput%tracers,fv3_filenameginput,dual_res) endif ier=0 call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_dynvar_nouv, 'tsen' ,g_tsen ,istatus );ier=ier+istatus diff --git a/src/gsi/gridmod.F90 b/src/gsi/gridmod.F90 index 559a3f576d..2367899ea5 100644 --- a/src/gsi/gridmod.F90 +++ b/src/gsi/gridmod.F90 @@ -93,6 +93,7 @@ module gridmod ! 2019-09-23 martin - add use_gfs_ncio to read global first guess from netCDF file ! 2020-12-18 Hu - add grid_type_fv3_regional ! 2021-12-30 Hu - add fv3_io_layout_y +! 2022-03-01 X.Lu & X.Wang - add corresponding variables for dual ens for HAFS. POC: xuguang.wang@ou.edu ! ! ! @@ -146,6 +147,7 @@ module gridmod public :: regional_fhr,region_dyi,coeffx,region_dxi,coeffy,nsig_hlf,regional_fmin public :: nsig2,wgtlats,corlats,rbs2,ncepgfs_headv,regional_time,wgtfactlats public :: nlat_regional,nlon_regional,update_regsfc,half_grid,gencode + public :: nlat_regionalens,nlon_regionalens public :: diagnostic_reg,nmmb_reference_grid,filled_grid public :: grid_ratio_nmmb,isd_g,isc_g,dx_gfs,lpl_gfs,nsig5,nmmb_verttype public :: grid_ratio_fv3_regional,fv3_io_layout_y,fv3_regional,fv3_cmaq_regional,grid_type_fv3_regional @@ -329,7 +331,7 @@ module gridmod real(r_kind) rlon_min_dd,rlon_max_dd,rlat_min_dd,rlat_max_dd real(r_kind) dt_ll,pdtop_ll,pt_ll - integer(i_kind) nlon_regional,nlat_regional + integer(i_kind) nlon_regional,nlat_regional,nlon_regionalens,nlat_regionalens real(r_kind) regional_fhr,regional_fmin integer(i_kind) regional_time(6) integer(i_kind) jcap_gfs,nlat_gfs,nlon_gfs @@ -485,6 +487,8 @@ subroutine init_grid update_regsfc = .false. nlon_regional = 0 nlat_regional = 0 + nlon_regionalens = 0 + nlat_regionalens = 0 msig = nsig do k=1,size(nlayers) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index e62cc06f2b..8158f35e11 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -18,6 +18,7 @@ module gsi_rfv3io_mod ! This function is needed when fv3 model sets ! io_layout(2)>1 ! 2022-02-15 Lu @ Wang - add time label it for FGAT. POC: xuguang.wang@ou.edu +! 2022-03-01 X.Lu @ X.Wang - add gsi_rfv3io_get_ens_grid_specs for dual ens HAFS. POC: xuguang.wang@ou.edu ! 2022-03-15 Hu - add code to read/write 2m T and Q for they will be ! used as background for surface observation operator ! 2022-04-15 Wang - add IO for regional FV3-CMAQ (RRFS-CMAQ) model @@ -27,6 +28,7 @@ module gsi_rfv3io_mod ! ! subroutines included: ! sub gsi_rfv3io_get_grid_specs +! sub gsi_rfv3io_get_ens_grid_specs ! sub read_fv3_files ! sub read_fv3_netcdf_guess ! sub gsi_fv3ncdf2d_read @@ -49,7 +51,7 @@ module gsi_rfv3io_mod !$$$ end documentation block use kinds, only: r_kind,i_kind - use gridmod, only: nlon_regional,nlat_regional + use gridmod, only: nlon_regional,nlat_regional,nlon_regionalens,nlat_regionalens use constants, only:max_varname_length,max_filename_length use gsi_bundlemod, only : gsi_bundle use general_sub2grid_mod, only: sub2grid_info @@ -82,7 +84,9 @@ module gsi_rfv3io_mod type(type_fv3regfilenameg),allocatable:: bg_fv3regfilenameg(:) integer(i_kind) nx,ny,nz + integer(i_kind) nxens,nyens integer(i_kind),dimension(:),allocatable :: ny_layout_len,ny_layout_b,ny_layout_e + integer(i_kind),dimension(:),allocatable :: ny_layout_lenens,ny_layout_bens,ny_layout_eens real(r_kind),allocatable:: grid_lon(:,:),grid_lont(:,:),grid_lat(:,:),grid_latt(:,:) real(r_kind),allocatable:: ak(:),bk(:) integer(i_kind),allocatable:: ijns2d(:),displss2d(:),ijns(:),displss(:) @@ -122,6 +126,7 @@ module gsi_rfv3io_mod private ! set subroutines to public public :: gsi_rfv3io_get_grid_specs + public :: gsi_rfv3io_get_ens_grid_specs public :: gsi_fv3ncdf_read public :: gsi_fv3ncdf_read_v1 public :: gsi_fv3ncdf_readuv @@ -500,6 +505,165 @@ subroutine gsi_rfv3io_get_grid_specs(ierr) return end subroutine gsi_rfv3io_get_grid_specs +subroutine gsi_rfv3io_get_ens_grid_specs(grid_spec,ierr) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_rfv3io_get_ens_grid_specs +! modified from gsi_rfv3io_get_grid_specs +! pgrmmr: parrish org: np22 date: 2017-04-03 +! +! abstract: obtain grid dimensions nx,ny and grid definitions +! grid_x,grid_xt,grid_y,grid_yt,grid_lon,grid_lont,grid_lat,grid_latt +! nz,ak(nz),bk(nz) +! +! program history log: +! 2017-04-03 parrish - initial documentation +! 2017-10-10 wu - setup A grid and interpolation coeff with generate_anl_grid +! 2018-02-16 wu - read in time info from file coupler.res +! read in lat, lon at the center and corner of the grid cell +! from file fv3_grid_spec, and vertical grid infor from file +! fv3_akbk +! setup A grid and interpolation/rotation coeff +! input argument list: +! grid_spec +! ak_bk +! lendian_out +! +! output argument list: +! ierr +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use mpimod, only: mype + use mod_fv3_lola, only: definecoef_regular_grids + use gridmod, only:nsig,regional_time,regional_fhr,regional_fmin,aeta1_ll,aeta2_ll + use gridmod, only:nlon_regionalens,nlat_regionalens + use gridmod, only:grid_type_fv3_regional + use kinds, only: i_kind,r_kind + use constants, only: half,zero + use mpimod, only: mpi_comm_world,mpi_itype,mpi_rtype + implicit none + character(:),allocatable,intent(in) :: grid_spec + + integer(i_kind) gfile_grid_spec + integer(i_kind),intent( out) :: ierr + integer(i_kind) i,k,ndimensions,iret,nvariables,nattributes,unlimiteddimid + integer(i_kind) gfile_loc,len + character(len=128) :: name + integer(i_kind) :: nio,nylen + integer(i_kind),allocatable :: gfile_loc_layout(:) + character(len=180) :: filename_layout + integer(i_kind) imiddle,jmiddle,grid_ens_type_fv3_regional + + + iret=nf90_open(trim(grid_spec),nf90_nowrite,gfile_grid_spec) + if(iret/=nf90_noerr) then + write(6,*)' problem opening1 ',trim(grid_spec),', Status = ',iret + ierr=1 + return + endif + iret=nf90_inquire(gfile_grid_spec,ndimensions,nvariables,nattributes,unlimiteddimid) + gfile_loc=gfile_grid_spec + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + if(trim(name)=='grid_xt') nxens=len + if(trim(name)=='grid_yt') nyens=len + enddo + allocate(grid_lat(nxens+1,nyens+1)) + allocate(grid_lon(nxens+1,nyens+1)) + allocate(grid_latt(nxens,nyens)) + allocate(grid_lont(nxens,nyens)) + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='grid_lat') then + iret=nf90_get_var(gfile_loc,k,grid_lat) + endif + if(trim(name)=='grid_lon') then + iret=nf90_get_var(gfile_loc,k,grid_lon) + endif + if(trim(name)=='grid_latt') then + iret=nf90_get_var(gfile_loc,k,grid_latt) + endif + if(trim(name)=='grid_lont') then + iret=nf90_get_var(gfile_loc,k,grid_lont) + endif + enddo + iret=nf90_close(gfile_loc) + + nlon_regionalens=nxens + nlat_regionalens=nyens + allocate(ny_layout_lenens(0:fv3_io_layout_y-1)) + allocate(ny_layout_bens(0:fv3_io_layout_y-1)) + allocate(ny_layout_eens(0:fv3_io_layout_y-1)) + ny_layout_lenens=nyens + ny_layout_bens=0 + ny_layout_eens=0 + if(fv3_io_layout_y > 1) then + allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) + do nio=0,fv3_io_layout_y-1 + write(filename_layout,'(a,a,I4.4)') trim(grid_spec),'.',nio + iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio)) + if(iret/=nf90_noerr) then + write(6,*)' problem opening ',trim(filename_layout),', Status =',iret + ierr=1 + return + endif + iret=nf90_inquire(gfile_loc_layout(nio),ndimensions,nvariables,nattributes,unlimiteddimid) + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc_layout(nio),k,name,len) + if(trim(name)=='grid_yt') ny_layout_lenens(nio)=len + enddo + iret=nf90_close(gfile_loc_layout(nio)) + enddo + deallocate(gfile_loc_layout) +! figure out begin and end of each subdomain restart file + nylen=0 + do nio=0,fv3_io_layout_y-1 + ny_layout_bens(nio)=nylen + 1 + nylen=nylen+ny_layout_lenens(nio) + ny_layout_eens(nio)=nylen + enddo + endif + if(mype==0)write(6,*),'nxens,nyens=',nxens,nyens + if(mype==0)write(6,*),'ny_layout_lenens=',ny_layout_lenens + if(mype==0)write(6,*),'ny_layout_bens=',ny_layout_bens + if(mype==0)write(6,*),'ny_layout_eens=',ny_layout_eens + + imiddle=nxens/2 + jmiddle=nyens/2 + if( (grid_latt(imiddle,1) < grid_latt(imiddle,nyens)) .and. & + (grid_lont(1,jmiddle) < grid_lont(nxens,jmiddle)) ) then + grid_ens_type_fv3_regional = 2 + else + grid_ens_type_fv3_regional = 1 + endif +! check the grid type + if( grid_type_fv3_regional == grid_ens_type_fv3_regional ) then + if(mype==0) write(6,*) 'Ensemble has the same orientation as the control, Cool!' + else + write(6,*) 'Warning! Ensemble has a different orientation as the control. This case needs further tests, Abort!' + call stop2(678) + endif +! + if(grid_type_fv3_regional == 2) then + call reverse_grid_r(grid_lont,nxens,nyens,1) + call reverse_grid_r(grid_latt,nxens,nyens,1) + call reverse_grid_r(grid_lon,nxens+1,nyens+1,1) + call reverse_grid_r(grid_lat,nxens+1,nyens+1,1) + endif + + call definecoef_regular_grids(nxens,nyens,grid_lon,grid_lont,grid_lat,grid_latt) + deallocate (grid_lon,grid_lat,grid_lont,grid_latt) + return +end subroutine gsi_rfv3io_get_ens_grid_specs + + subroutine read_fv3_files(mype) !$$$ subprogram documentation block ! . . . . @@ -1110,7 +1274,9 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif end do if (ndynvario2d > 0) then - allocate(fv3lam_io_dynmetvars2d_nouv(ndynvario2d)) + if (.not. allocated(fv3lam_io_dynmetvars2d_nouv)) then + allocate(fv3lam_io_dynmetvars2d_nouv(ndynvario2d)) + end if endif if (ntracerio2d > 0) then allocate(fv3lam_io_tracermetvars2d_nouv(ntracerio2d)) @@ -1421,40 +1587,40 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) end if if( fv3sar_bg_opt == 0) then - call gsi_fv3ncdf_readuv(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it)) + call gsi_fv3ncdf_readuv(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) else - call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it)) + call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) endif if( fv3sar_bg_opt == 0) then call gsi_fv3ncdf_read(grd_fv3lam_dynvar_ionouv,gsibundle_fv3lam_dynvar_nouv & - & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it)) + & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it),.false.) call gsi_fv3ncdf_read(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) if( nphyvario3d > 0 )then call gsi_fv3ncdf_read(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv & - & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it)) + & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it),.false.) end if if (laeroana_fv3cmaq) then call gsi_fv3ncdf_read(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) endif if (laeroana_fv3smoke) then call gsi_fv3ncdf_read(grd_fv3lam_tracersmoke_ionouv,gsibundle_fv3lam_tracersmoke_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) endif else call gsi_fv3ncdf_read_v1(grd_fv3lam_dynvar_ionouv,gsibundle_fv3lam_dynvar_nouv & - & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it)) + & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it),.false.) call gsi_fv3ncdf_read_v1(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) if (laeroana_fv3cmaq) then call gsi_fv3ncdf_read_v1(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) endif if (laeroana_fv3smoke) then call gsi_fv3ncdf_read_v1(grd_fv3lam_tracersmoke_ionouv,gsibundle_fv3lam_tracersmoke_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) endif endif @@ -2220,7 +2386,7 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io) return end subroutine gsi_fv3ncdf2d_read_v1 -subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) +subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ensgrid) !$$$ subprogram documentation block ! . . . . ! subprogram: gsi_fv3ncdf_read @@ -2253,7 +2419,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid - use mod_fv3_lola, only: fv3_h_to_ll + use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_grid2sub @@ -2262,6 +2428,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) type(gsi_bundle),intent(inout) :: cstate_nouv character(*),intent(in):: filenamein type (type_fv3regfilenameg),intent(in) ::fv3filenamegin + logical, intent(in ) :: ensgrid real(r_kind),allocatable,dimension(:,:):: uu2d real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork character(len=max_varname_length) :: varname,vgsiname @@ -2290,8 +2457,13 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) mm1=mype+1 nloncase=grd_ionouv%nlon nlatcase=grd_ionouv%nlat - nxcase=nx - nycase=ny + if (ensgrid) then + nxcase=nxens + nycase=nyens + else + nxcase=nx + nycase=ny + end if kbgn=grd_ionouv%kbegin_loc kend=grd_ionouv%kend_loc allocate(uu2d(nxcase,nycase)) @@ -2376,11 +2548,20 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) - allocate(uu2d_layout(nxcase,ny_layout_len(nio))) + if (ensgrid) then + countloc=(/nxcase,ny_layout_lenens(nio)+1,1/) + allocate(uu2d_layout(nxcase,ny_layout_lenens(nio)+1)) + else + countloc=(/nxcase,ny_layout_len(nio),1/) + allocate(uu2d_layout(nxcase,ny_layout_len(nio))) + end if iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc) - uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout + if (ensgrid) then + uu2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=uu2d_layout + else + uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout + end if deallocate(uu2d_layout) enddo else @@ -2403,7 +2584,11 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) end if endif - call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + if (ensgrid) then + call fv3_h_to_ll_ens(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + else + call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + endif enddo ! ilevtot if(fv3_io_layout_y > 1) then @@ -2423,7 +2608,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) return end subroutine gsi_fv3ncdf_read -subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) +subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ensgrid) !$$$ subprogram documentation block ! . . . . @@ -2458,13 +2643,14 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid - use mod_fv3_lola, only: fv3_h_to_ll + use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none type(sub2grid_info), intent(in):: grd_ionouv character(*),intent(in):: filenamein + logical, intent(in ) :: ensgrid type (type_fv3regfilenameg) :: fv3filenamegin type(gsi_bundle),intent(inout) :: cstate_nouv real(r_kind),allocatable,dimension(:,:):: uu2d @@ -2484,8 +2670,13 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) nloncase=grd_ionouv%nlon nlatcase=grd_ionouv%nlat - nxcase=nx - nycase=ny + if (ensgrid) then + nxcase=nxens + nycase=nyens + else + nxcase=nx + nycase=ny + end if kbgn=grd_ionouv%kbegin_loc kend=grd_ionouv%kend_loc allocate(uu2d(nxcase,nycase)) @@ -2519,7 +2710,11 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc) - call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + if (ensgrid) then + call fv3_h_to_ll_ens(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + else + call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + end if enddo ! i call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values) @@ -2531,7 +2726,7 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) return end subroutine gsi_fv3ncdf_read_v1 -subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) +subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) !$$$ subprogram documentation block ! . . . . ! subprogram: gsi_fv3ncdf_readuv @@ -2558,7 +2753,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid - use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth + use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth,fv3_h_to_ll_ens,fv3uv2earthens use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none @@ -2566,6 +2761,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_u real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_v type (type_fv3regfilenameg),intent (in) :: fv3filenamegin + logical, intent(in ) :: ensgrid real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork character(:), allocatable:: filenamein real(r_kind),allocatable,dimension(:,:):: u2d,v2d @@ -2596,8 +2792,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) mm1=mype+1 nloncase=grd_uv%nlon nlatcase=grd_uv%nlat - nxcase=nx - nycase=ny + if (ensgrid) then + nxcase=nxens + nycase=nyens + else + nxcase=nx + nycase=ny + end if kbgn=grd_uv%kbegin_loc kend=grd_uv%kend_loc allocate(u2d(nxcase,nycase+1)) @@ -2667,19 +2868,35 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) v_startloc=(/1,1,inative/) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) + if (ensgrid) then + u_countloc=(/nxcase,ny_layout_lenens(nio)+1,1/) + allocate(u2d_layout(nxcase,ny_layout_lenens(nio)+1)) + else + u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) + end if call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc) - u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) - if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) - deallocate(u2d_layout) - - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) + if (ensgrid) then + u2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=u2d_layout(:,1:ny_layout_lenens(nio)) + if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_eens(nio)+1)=u2d_layout(:,ny_layout_lenens(nio)+1) + deallocate(u2d_layout) + v_countloc=(/nxcase+1,ny_layout_lenens(nio),1/) + allocate(v2d_layout(nxcase+1,ny_layout_lenens(nio))) + else + u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) + if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) + deallocate(u2d_layout) + v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) + end if call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc) - v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout + if (ensgrid) then + v2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=v2d_layout + else + v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout + end if deallocate(v2d_layout) enddo else @@ -2693,7 +2910,11 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) call reverse_grid_r_uv (u2d,nxcase,nycase+1,1) call reverse_grid_r_uv (v2d,nxcase+1,nycase,1) endif - call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + if (ensgrid) then + call fv3uv2earthens(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + else + call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + end if ! NOTE on transfor to earth u/v: ! The u and v before transferring need to be in E-W/N-S grid, which is @@ -2711,8 +2932,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) ! and the last input parameter for fv3_h_to_ll is alway true: ! ! - call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) - call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + if (ensgrid) then + call fv3_h_to_ll_ens(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + call fv3_h_to_ll_ens(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + else + call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + end if enddo ! i if(fv3_io_layout_y > 1) then @@ -2734,7 +2960,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) deallocate(worksub) end subroutine gsi_fv3ncdf_readuv -subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) +subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) !$$$ subprogram documentation block ! subprogram: gsi_fv3ncdf_readuv_v1 ! prgmmr: wu w org: np22 date: 2017-11-22 @@ -2762,7 +2988,7 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid - use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth + use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none @@ -2770,6 +2996,7 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) real(r_kind) ,intent(out ) :: ges_u(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig) real(r_kind) ,intent(out ) :: ges_v(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig) type (type_fv3regfilenameg),intent (in) :: fv3filenamegin + logical, intent(in ) :: ensgrid real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork character(len=:),allocatable :: filenamein real(r_kind),allocatable,dimension(:,:):: us2d,vw2d @@ -2792,8 +3019,13 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) mm1=mype+1 nloncase=grd_uv%nlon nlatcase=grd_uv%nlat - nxcase=nx - nycase=ny + if (ensgrid) then + nxcase=nxens + nycase=nyens + else + nxcase=nx + nycase=ny + end if kbgn=grd_uv%kbegin_loc kend=grd_uv%kend_loc allocate (us2d(nxcase,nycase+1),vw2d(nxcase+1,nycase)) @@ -2818,8 +3050,13 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) nz=grd_uv%nsig nzp1=nz+1 inative=nzp1-ilev - us_countloc= (/nlon_regional,nlat_regional+1,1/) - vw_countloc= (/nlon_regional+1,nlat_regional,1/) + if (ensgrid) then + us_countloc= (/nlon_regionalens,nlat_regionalens+1,1/) + vw_countloc= (/nlon_regionalens+1,nlat_regionalens,1/) + else + us_countloc= (/nlon_regional,nlat_regional+1,1/) + vw_countloc= (/nlon_regional+1,nlat_regional,1/) + end if us_startloc=(/1,1,inative+1/) vw_startloc=(/1,1,inative+1/) @@ -2834,11 +3071,19 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) uorv2d(:,j)=half*(us2d(:,j)+us2d(:,j+1)) enddo - call fv3_h_to_ll(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + if (ensgrid) then + call fv3_h_to_ll_ens(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + else + call fv3_h_to_ll(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + end if do j=1,nx uorv2d(j,:)=half*(vw2d(j,:)+vw2d(j+1,:)) enddo - call fv3_h_to_ll(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + if (ensgrid) then + call fv3_h_to_ll_ens(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + else + call fv3_h_to_ll(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + end if enddo ! iilevtoto call general_grid2sub(grd_uv,hwork,worksub) diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 4bad129a72..ef6b53119c 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -4001,7 +4001,8 @@ subroutine hybens_grid_setup ! 2010-02-20 parrish, adapt for dual resolution ! 2011-01-30 parrish, fix so regional application depends only on parameters regional ! and dual_res. Rename subroutine get_regional_gefs_grid to get_regional_dual_res_grid. -! +! +! 2022-03-01 X.Lu & X.Wang - add vars for hafs dual ens. POC: xuguang.wang@ou.edu ! input argument list: ! ! output argument list: @@ -4027,6 +4028,8 @@ subroutine hybens_grid_setup use control_vectors, only: cvars3d,nc2d,nc3d use gridmod, only: region_lat,region_lon,region_dx,region_dy use hybrid_ensemble_parameters, only:nsclgrp,spc_multwgt,spcwgt_params,global_spectral_filter_sd + use hybrid_ensemble_parameters, only:regional_ensemble_option + use gsi_rfv3io_mod,only:gsi_rfv3io_get_ens_grid_specs implicit none @@ -4035,6 +4038,8 @@ subroutine hybens_grid_setup logical,allocatable::vector(:) real(r_kind) eps,r_e real(r_kind) rlon_a(nlon),rlat_a(nlat),rlon_e(nlon),rlat_e(nlat) + character(:),allocatable:: fv3_ens_spec_grid_filename + integer :: ierr nord_e2a=4 ! soon, move this to hybrid_ensemble_parameters @@ -4121,6 +4126,10 @@ subroutine hybens_grid_setup else if(dual_res) then call get_region_dx_dy_ens(region_dx_ens,region_dy_ens) + if(regional_ensemble_option == 5) then + fv3_ens_spec_grid_filename="fv3_ens_grid_spec" + call gsi_rfv3io_get_ens_grid_specs(fv3_ens_spec_grid_filename,ierr) + endif else region_dx_ens=region_dx region_dy_ens=region_dy diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90 index ebe0816c4a..4ec3c0cb93 100644 --- a/src/gsi/mod_fv3_lola.f90 +++ b/src/gsi/mod_fv3_lola.f90 @@ -18,12 +18,17 @@ module mod_fv3_lola ! fv3_ll_to_h ! 2019-11-01 wu - add checks in generate_anl_grid to present the mean ! longitude correctly to fix problem near lon=0 +! 2022-03-01 X.Lu & X.Wang - add functions for HAFS dual ens capability. POC: +! xuguang.wang@ou.edu ! ! subroutines included: ! sub generate_anl_grid +! sub definecoef_regular_grids ! sub earthuv2fv3 ! sub fv3uv2earth +! sub fv3uv2earthens ! sub fv3_h_to_ll +! sub fv3_h_to_ll_ens ! sub fv3_ll_to_h ! sub rotate2deg ! sub unrotate2deg @@ -65,6 +70,9 @@ module mod_fv3_lola public :: generate_anl_grid,fv3_h_to_ll,fv3_ll_to_h,fv3uv2earth,earthuv2fv3 public :: fv3dx,fv3dx1,fv3dy,fv3dy1,fv3ix,fv3ixp,fv3jy,fv3jyp,a3dx,a3dx1,a3dy,a3dy1,a3ix,a3ixp,a3jy,a3jyp public :: nxa,nya,cangu,sangu,cangv,sangv,nx,ny,bilinear + public :: definecoef_regular_grids,fv3_h_to_ll_ens,fv3uv2earthens + public :: fv3dxens,fv3dx1ens,fv3dyens,fv3dy1ens,fv3ixens,fv3ixpens,fv3jyens,fv3jypens,a3dxens,a3dx1ens,a3dyens,a3dy1ens,a3ixens,a3ixpens,a3jyens,a3jypens + public :: nxe,nye,canguens,sanguens,cangvens,sangvens logical bilinear integer(i_kind) nxa,nya,nx,ny @@ -73,6 +81,12 @@ module mod_fv3_lola real(r_kind) ,allocatable,dimension(:,:):: a3dx,a3dx1,a3dy,a3dy1 real(r_kind) ,allocatable,dimension(:,:):: cangu,sangu,cangv,sangv integer(i_kind),allocatable,dimension(:,:):: a3ix,a3ixp,a3jy,a3jyp + integer(i_kind) nxe,nye + real(r_kind) ,allocatable,dimension(:,:):: fv3dxens,fv3dx1ens,fv3dyens,fv3dy1ens + integer(i_kind),allocatable,dimension(:,:):: fv3ixens,fv3ixpens,fv3jyens,fv3jypens + real(r_kind) ,allocatable,dimension(:,:):: a3dxens,a3dx1ens,a3dyens,a3dy1ens + real(r_kind) ,allocatable,dimension(:,:):: canguens,sanguens,cangvens,sangvens + integer(i_kind),allocatable,dimension(:,:):: a3ixens,a3ixpens,a3jyens,a3jypens contains @@ -574,8 +588,425 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) enddo enddo deallocate( xc,yc,zc,gclat,gclon,gcrlat,gcrlon) + deallocate(rlat_in,rlon_in) end subroutine generate_anl_grid +subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_latt) +!$$$ subprogram documentation block +! . . . . +! subprogram: generate_??ens_grid +!clt modified from generate_regular_grid +! prgmmr: parrish +! +! abstract: define rotated lat-lon analysis grid which is centered on fv3 tile +! and oriented to completely cover the tile. +! +! program history log: +! 2017-05-02 parrish +! 2017-10-10 wu - 1. setup analysis A-grid, +! 2. compute/setup FV3 to A grid interpolation parameters +! 3. compute/setup A to FV3 grid interpolation parameters +! 4. setup weightings for wind conversion from FV3 to earth +! 2021-02-01 Lu & Wang - modify variable intent for HAFS dual ens. POC: +! xuguang.wang@ou.edu +! +! input argument list: +! nxen, nyen - number of cells = nxen*nyen +! grid_lon ,grid_lat - longitudes and latitudes of fv3 grid cell corners +! grid_lont,grid_latt - longitudes and latitudes of fv3 grid cell centers +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use constants, only: quarter,one,two,half,zero,deg2rad,rearth,rad2deg + use gridmod, only:grid_ratio_fv3_regional + use mpimod, only: mype + use hybrid_ensemble_parameters, only: nlon_ens,nlat_ens,region_lon_ens,region_lat_ens + implicit none + real(r_kind),allocatable,dimension(:)::xbh_a,xa_a,xa_b + real(r_kind),allocatable,dimension(:)::ybh_a,ya_a,ya_b,yy + real(r_kind),allocatable,dimension(:,:)::xbh_b,ybh_b + real(r_kind) dlat,dlon,dyy,dxx,dyyi,dxxi + real(r_kind) dyyh,dxxh + + real(r_kind),allocatable:: region_lat_tmp(:,:),region_lon_tmp(:,:) + integer(i_kind), intent(in ) :: nxen,nyen ! fv3 tile x- and y-dimensions + real(r_kind) , intent(inout) :: grid_lon(nxen+1,nyen+1) ! fv3 cell corner longitudes + real(r_kind) , intent(inout) :: grid_lont(nxen,nyen) ! fv3 cell center longitudes + real(r_kind) , intent(inout) :: grid_lat(nxen+1,nyen+1) ! fv3 cell corner latitudes + real(r_kind) , intent(inout) :: grid_latt(nxen,nyen) ! fv3 cell center latitudes + integer(i_kind) i,j,ir,jr,n + real(r_kind),allocatable,dimension(:,:) :: xc,yc,zc,gclat,gclon,gcrlat,gcrlon,rlon_in,rlat_in + real(r_kind),allocatable,dimension(:,:) :: glon_an,glat_an + real(r_kind) xcent,ycent,zcent,rnorm,centlat,centlon + integer(i_kind) nlonh,nlath,nxh,nyh + integer(i_kind) ib1,ib2,jb1,jb2,jj + integer (i_kind):: index0 + real(r_kind) region_lat_in(nlat_ens,nlon_ens),region_lon_in(nlat_ens,nlon_ens) + integer(i_kind) nord_e2a + real(r_kind)gxa,gya + + real(r_kind) x(nxen+1,nyen+1),y(nxen+1,nyen+1),z(nxen+1,nyen+1),xr,yr,zr,xu,yu,zu,rlat,rlon + real(r_kind) xv,yv,zv,vval + real(r_kind) cx,cy + real(r_kind) uval,ewval,nsval + + real(r_kind) d(4),ds + integer(i_kind) kk,k + real(r_kind) diff,sq180 + + nord_e2a=4 + bilinear=.false. + +! create xc,yc,zc for the cell centers. + allocate(xc(nxen,nyen)) + allocate(yc(nxen,nyen)) + allocate(zc(nxen,nyen)) + allocate(gclat(nxen,nyen)) + allocate(gclon(nxen,nyen)) + allocate(gcrlat(nxen,nyen)) + allocate(gcrlon(nxen,nyen)) + do j=1,nyen + do i=1,nxen + xc(i,j)=cos(grid_latt(i,j)*deg2rad)*cos(grid_lont(i,j)*deg2rad) + yc(i,j)=cos(grid_latt(i,j)*deg2rad)*sin(grid_lont(i,j)*deg2rad) + zc(i,j)=sin(grid_latt(i,j)*deg2rad) + enddo + enddo + +! compute center as average x,y,z coordinates of corners of domain -- + + xcent=quarter*(xc(1,1)+xc(1,nyen)+xc(nxen,1)+xc(nxen,nyen)) + ycent=quarter*(yc(1,1)+yc(1,nyen)+yc(nxen,1)+yc(nxen,nyen)) + zcent=quarter*(zc(1,1)+zc(1,nyen)+zc(nxen,1)+zc(nxen,nyen)) + + rnorm=one/sqrt(xcent**2+ycent**2+zcent**2) + xcent=rnorm*xcent + ycent=rnorm*ycent + zcent=rnorm*zcent + centlat=asin(zcent)*rad2deg + centlon=atan2(ycent,xcent)*rad2deg + +!! compute new lats, lons + call rotate2deg(grid_lont,grid_latt,gcrlon,gcrlat, & + centlon,centlat,nxen,nyen) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! compute analysis A-grid lats, lons +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!--------------------------obtain analysis grid dimensions nxe,nye + nxe=nlon_ens + nye=nlat_ens + if(mype==0) print *,'nlat,nlon=nye,nxe= ',nlat_ens,nlon_ens + + allocate(rlat_in(nlat_ens,nlon_ens),rlon_in(nlat_ens,nlon_ens)) + allocate(region_lon_tmp(nlat_ens,nlon_ens),region_lat_tmp(nlat_ens,nlon_ens)) + region_lon_tmp=region_lon_ens*rad2deg + region_lat_tmp=region_lat_ens*rad2deg + call rotate2deg(region_lon_tmp,region_lat_tmp,rlon_in,rlat_in, & + centlon,centlat,nlat_ens,nlon_ens) + +!--------------------------obtain analysis grid spacing + dlat=(maxval(gcrlat)-minval(gcrlat))/(nyen-1) + dlon=(maxval(gcrlon)-minval(gcrlon))/(nxen-1) + + +!-----setup analysis A-grid from center of the domain +!--------------------compute all combinations of relative coordinates + + allocate(xbh_a(nxen),xbh_b(nxen,nyen),xa_a(nxe),xa_b(nxe)) + allocate(ybh_a(nyen),ybh_b(nxen,nyen),ya_a(nye),ya_b(nye)) + + nxh=nxen/2 + nyh=nyen/2 + + +!!!!!! fv3 rotated grid; not equal spacing, non_orthogonal !!!!!! + do j=1,nyen + jr=nyen+1-j + do i=1,nxen + ir=nxen+1-i + xbh_b(ir,jr)=gcrlon(i,j)/dlon + end do + end do + do j=1,nyen + jr=nyen+1-j + do i=1,nxen + ir=nxen+1-i + ybh_b(ir,jr)=gcrlat(i,j)/dlat + end do + end do + +!!!! define analysis A grid !!!!!!!!!!!!! + + index0=1 + do j=1,nxe + xa_a(j)= rlon_in(index0,j)/dlon + end do + do i=1,nye + ya_a(i)= rlat_in(i,index0)/dlat + end do + +!!!!!compute fv3 to A grid interpolation parameters !!!!!!!!! + allocate (fv3dxens(nxe,nye),fv3dx1ens(nxe,nye),fv3dyens(nxe,nye),fv3dy1ens(nxe,nye)) + allocate (fv3ixens(nxe,nye),fv3ixpens(nxe,nye),fv3jyens(nxe,nye),fv3jypens(nxe,nye)) + allocate(yy(nyen)) + +! iteration to find the fv3 grid cell + jb1=1 + ib1=1 + do j=1,nye + do i=1,nxe + do n=1,3 + gxa=xa_a(i) + if(gxa < xbh_b(1,jb1))then + gxa= 1 + else if(gxa > xbh_b(nxen,jb1))then + gxa= nxen + else + call grdcrd1(gxa,xbh_b(1,jb1),nxen,1) + endif + ib2=ib1 + ib1=gxa + do jj=1,nyen + yy(jj)=ybh_b(ib1,jj) + enddo + gya=ya_a(j) + if(gya < yy(1))then + gya= 1 + else if(gya > yy(nyen))then + gya= nyen + else + call grdcrd1(gya,yy,nyen,1) + endif + jb2=jb1 + jb1=gya + if(ib1+1 > nxen)then !this block( 6 lines) is copied from GSL gsi repository + ib1=ib1-1 + endif + if(jb1+1 > nyen)then + jb1=jb1-1 + endif + + if((ib1 == ib2) .and. (jb1 == jb2)) exit + if(n==3 ) then +!!!!!!! if not converge, find the nearest corner point + d(1)=(xa_a(i)-xbh_b(ib1,jb1))**2+(ya_a(j)-ybh_b(ib1,jb1))**2 + d(2)=(xa_a(i)-xbh_b(ib1+1,jb1))**2+(ya_a(j)-ybh_b(ib1+1,jb1))**2 + d(3)=(xa_a(i)-xbh_b(ib1,jb1+1))**2+(ya_a(j)-ybh_b(ib1,jb1+1))**2 + d(4)=(xa_a(i)-xbh_b(ib1+1,jb1+1))**2+(ya_a(j)-ybh_b(ib1+1,jb1+1))**2 + kk=1 + do k=2,4 + if(d(k) xa_a(nxe))then + gxa= nxe + else + call grdcrd1(gxa,xa_a,nxe,1) + endif + a3ixens(j,i)=int(gxa) + a3ixens(j,i)=min(max(1,a3ixens(j,i)),nxe) + a3dxens(j,i)=max(zero,min(one,gxa-a3ixens(j,i))) + a3dx1ens(j,i)=one-a3dxens(j,i) + a3ixpens(j,i)=min(nxe,a3ixens(j,i)+1) + end do + end do + + do i=1,nxen + do j=1,nyen + gya=ybh_b(i,j) + if(gya < ya_a(1))then + gya= 1 + else if(gya > ya_a(nye))then + gya= nye + else + call grdcrd1(gya,ya_a,nye,1) + endif + a3jyens(j,i)=int(gya) + a3jyens(j,i)=min(max(1,a3jyens(j,i)),nye) + a3dyens(j,i)=max(zero,min(one,gya-a3jyens(j,i))) + a3dy1ens(j,i)=one-a3dyens(j,i) + a3jypens(j,i)=min(nye,a3jyens(j,i)+1) + end do + end do + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! find coefficients for wind conversion btw FV3 & earth +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + allocate (canguens(nxen,nyen+1),sanguens(nxen,nyen+1),cangvens(nxen+1,nyen),sangvens(nxen+1,nyen)) + +! 1. compute x,y,z at cell cornor from grid_lon, grid_lat + + do j=1,nyen+1 + do i=1,nxen+1 + x(i,j)=cos(grid_lat(i,j)*deg2rad)*cos(grid_lon(i,j)*deg2rad) + y(i,j)=cos(grid_lat(i,j)*deg2rad)*sin(grid_lon(i,j)*deg2rad) + z(i,j)=sin(grid_lat(i,j)*deg2rad) + enddo + enddo + +! 2 find angles to E-W and N-S for U edges + + sq180=180._r_kind**2 + do j=1,nyen+1 + do i=1,nxen +! center lat/lon of the edge + rlat=half*(grid_lat(i,j)+grid_lat(i+1,j)) +! rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 + if(diff < sq180)then + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + else + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind) + endif +! vector to center of the edge + xr=cos(rlat*deg2rad)*cos(rlon*deg2rad) + yr=cos(rlat*deg2rad)*sin(rlon*deg2rad) + zr=sin(rlat*deg2rad) +! vector of the edge + xu= x(i+1,j)-x(i,j) + yu= y(i+1,j)-y(i,j) + zu= z(i+1,j)-z(i,j) +! find angle with cross product + uval=sqrt((xu**2+yu**2+zu**2)) + ewval=sqrt((xr**2+yr**2)) + nsval=sqrt((xr*zr)**2+(zr*yr)**2+(xr*xr+yr*yr)**2) + canguens(i,j)=(-yr*xu+xr*yu)/ewval/uval + sanguens(i,j)=(-xr*zr*xu-zr*yr*yu+(xr*xr+yr*yr)*zu) / nsval/uval + enddo + enddo + +! 3 find angles to E-W and N-S for V edges + do j=1,nyen + do i=1,nxen+1 + rlat=half*(grid_lat(i,j)+grid_lat(i,j+1)) +! rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)) + diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 + if(diff < sq180)then + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + else + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind) + endif + xr=cos(rlat*deg2rad)*cos(rlon*deg2rad) + yr=cos(rlat*deg2rad)*sin(rlon*deg2rad) + zr=sin(rlat*deg2rad) + xv= x(i,j+1)-x(i,j) + yv= y(i,j+1)-y(i,j) + zv= z(i,j+1)-z(i,j) + vval=sqrt((xv**2+yv**2+zv**2)) + ewval=sqrt((xr**2+yr**2)) + nsval=sqrt((xr*zr)**2+(zr*yr)**2+(xr*xr+yr*yr)**2) + cangvens(i,j)=(-yr*xv+xr*yv)/ewval/vval + sangvens(i,j)=(-xr*zr*xv-zr*yr*yv+(xr*xr+yr*yr)*zv) / nsval/vval + enddo + enddo + deallocate( xc,yc,zc,gclat,gclon,gcrlat,gcrlon) + deallocate(rlat_in,rlon_in) +end subroutine definecoef_regular_grids + subroutine earthuv2fv3(u,v,nx,ny,u_out,v_out) !$$$ subprogram documentation block ! . . . . @@ -679,6 +1110,51 @@ subroutine fv3uv2earth(u,v,nx,ny,u_out,v_out) return end subroutine fv3uv2earth +subroutine fv3uv2earthens(u,v,nxen,nyen,u_out,v_out) +!$$$ subprogram documentation block +! . . . . +! subprogram: fv3uv2earthens +! prgmmr: wu 2017-06-15 +! +! abstract: project fv3 UV to earth UV and interpolate to the center of the +! cells +! +! program history log: +! +! +! input argument list: +! u,v - fv3 winds on the cell boundaries +! nx,ny - dimensions +! +! output argument list: +! u_out,v_out - output earth wind components at center of the cell +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use constants, only: half + implicit none + + integer(i_kind), intent(in ) :: nxen,nyen ! fv3 tile x- and y-dimensions + real(r_kind),intent(in ) :: u(nxen,nyen+1),v(nxen+1,nyen) + real(r_kind),intent( out) :: u_out(nxen,nyen),v_out(nxen,nyen) + integer(i_kind) i,j + + do j=1,nyen + do i=1,nxen + u_out(i,j)=half *((u(i,j)*sangvens(i,j)-v(i,j)*sanguens(i,j))/(canguens(i,j)*sangvens(i,j)-sanguens(i,j)*cangvens(i,j)) & + +(u(i,j+1)*sangvens(i+1,j)-v(i+1,j)*sanguens(i,j+1))/(canguens(i,j+1)*sangvens(i+1,j)-sanguens(i,j+1)*cangvens(i+1,j))) + v_out(i,j)=half *((u(i,j)*cangvens(i,j)-v(i,j)*canguens(i,j))/(sanguens(i,j)*cangvens(i,j)-canguens(i,j)*sangvens(i,j)) & + +(u(i,j+1)*cangvens(i+1,j)-v(i+1,j)*canguens(i,j+1))/(sanguens(i,j+1)*cangvens(i+1,j)-canguens(i,j+1)*sangvens(i+1,j))) + end do + end do + return +end subroutine fv3uv2earthens + subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma,rev_flg) !$$$ subprogram documentation block ! . . . . @@ -753,6 +1229,86 @@ subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma,rev_flg) return end subroutine fv3_h_to_ll +subroutine fv3_h_to_ll_ens(b_in,a,nb,mb,na,ma,rev_flg) +!$$$ subprogram documentation block +! . . . . +! subprogram: fv3_h_to_ll +! prgmmr: wu 2017-05-30 +! +! abstract: interpolate from rotated fv3 grid to A grid. +! Interpolation choices 1)bilinear both ways +! 2)inverse-distance weighting average +! reverse E-W and N-S directions & reverse i,j for output array a(nlat,nlon) +! +! program history log: +! +! +! input argument list: +! mb,nb - fv3 dimensions +! ma,na - a dimensions +! b - input variable b +! xb,yb - b array x and y coordinates +! xa,ya - a array coordinates (xa in xb units, ya in yb units) +! +! output argument list: +! a - output interpolated array +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use mpimod, only: mype + use constants, only: zero,one + implicit none + + integer(i_kind),intent(in ) :: mb,nb,ma,na + real(r_kind) ,intent(in ) :: b_in(nb,mb) + logical ,intent(in ) :: rev_flg + real(r_kind) ,intent( out) :: a(ma,na) + + integer(i_kind) i,j,ir,jr,mbp,nbp + real(r_kind) b(nb,mb) + + mbp=mb+1 + nbp=nb+1 + bilinear=.false. + if(rev_flg) then +!!!!!!!!! reverse E-W and N-S + do j=1,mb + jr=mbp-j + do i=1,nb + ir=nbp-i + b(ir,jr)=b_in(i,j) + end do + end do + else + b(:,:)=b_in(:,:) + endif +!!!!!!!!! interpolate to A grid & reverse ij for array a(lat,lon) + if(bilinear)then ! bilinear interpolation + do j=1,ma + do i=1,na + a(j,i)=fv3dx1ens(i,j)*(fv3dy1ens(i,j)*b(fv3ixens(i,j),fv3jyens(i,j)) & + +fv3dyens(i,j)*b(fv3ixens(i,j),fv3jypens(i,j))) & + +fv3dxens(i,j)*(fv3dy1ens(i,j)*b(fv3ixpens(i,j),fv3jyens(i,j)) & + +fv3dyens(i,j)*b(fv3ixpens(i,j),fv3jypens(i,j))) + end do + end do + else ! inverse-distance weighting average + do j=1,ma + do i=1,na + a(j,i)=fv3dxens(i,j)*b(fv3ixens(i,j),fv3jyens(i,j)) & + +fv3dyens(i,j)*b(fv3ixens(i,j),fv3jypens(i,j)) & + +fv3dx1ens(i,j)*b(fv3ixpens(i,j),fv3jyens(i,j)) & + +fv3dy1ens(i,j)*b(fv3ixpens(i,j),fv3jypens(i,j)) + end do + end do + endif + + return +end subroutine fv3_h_to_ll_ens + subroutine fv3_ll_to_h(a,b,nxa,nya,nxb,nyb,rev_flg) !$$$ subprogram documentation block ! . . . . From 2353eaa7ed753db84c8e3fbaad6927cd54c2f893 Mon Sep 17 00:00:00 2001 From: daviddowellNOAA <72174157+daviddowellNOAA@users.noreply.github.com> Date: Thu, 7 Dec 2023 10:02:04 -0600 Subject: [PATCH 4/4] Add assimilation of GLM flash-extent density (FED) observations to EnKF (#654) **Description** Fixes https://github.com/NOAA-EMC/GSI/issues/653 The proposed code changes (1) add a new "fed" observation type to the EnKF (2) add localization parameters, with namelist control, for FED observations (3) output basic statistics for FED observations. In the RRFS, the FED observations will be assimilated together with radar-reflectivity observations. The localization parameters for the reflectivity observations in RRFS are corrlength=18 and lnsigcutoff=0.5. However, these tight localization distances don't work well for the sparse FED observations. Therefore, localization parameters for FED observations, with namelist control, were added to allow the FED observations to influence the model state over longer distances. The default localization parameters for FED observations (corrlength=30 and lnsigcutoff=2.0) were determined through experimentation with WRF and FV3 convection-allowing (3-km horizontal grid spacing) ensembles. **Type of change** - [X] New feature (non-breaking change which adds functionality) **How Has This Been Tested?** Hourly cycling with simultaneous EnKF assimilation of FED and radar-reflectivity observations has been tested for a CONUS version of the prototype RRFSv1 for two short (1-2 days) retrospective periods, one in July 2022 and the other in August 2023. The impacts of the FED observations on the analyses are greatest over the oceans far from land, where the radar network does not provide observations. --- src/enkf/enkf.f90 | 2 +- src/enkf/enkf_obs_sensitivity.f90 | 3 +++ src/enkf/enkf_obsmod.f90 | 7 +++++++ src/enkf/innovstats.f90 | 16 ++++++++++++++++ src/enkf/params.f90 | 15 +++++++++++++++ src/enkf/readconvobs.f90 | 12 +++++++++--- 6 files changed, 51 insertions(+), 4 deletions(-) diff --git a/src/enkf/enkf.f90 b/src/enkf/enkf.f90 index d35613b585..479f60c019 100644 --- a/src/enkf/enkf.f90 +++ b/src/enkf/enkf.f90 @@ -51,7 +51,7 @@ module enkf ! NH, tropics and SH, and in the horizontal, vertical and time dimensions, ! using the namelist parameters corrlengthnh, corrlengthtr, corrlengthsh, ! lnsigcutoffnh, lnsigcutofftr, lnsigcutoffsh (lnsigcutoffsatnh, -! lnsigcutoffsattr, lnsigcutoffsatsh for satellite obs, similar for ps obs) +! lnsigcutoffsattr, lnsigcutoffsatsh for satellite obs, similar for ps and fed obs) ! obtimelnh, obtimeltr, obtimelsh. The length scales should be given in km for the ! horizontal, hours for time, and 'scale heights' (units of -log(p/pref)) in the ! vertical. The function used for localization (function taper) diff --git a/src/enkf/enkf_obs_sensitivity.f90 b/src/enkf/enkf_obs_sensitivity.f90 index 6c37936f31..72296d5934 100644 --- a/src/enkf/enkf_obs_sensitivity.f90 +++ b/src/enkf/enkf_obs_sensitivity.f90 @@ -36,6 +36,7 @@ module enkf_obs_sensitivity use params, only: efsoi_flag,latbound,nlevs,nanals,datestring, & lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh, & lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh, & + lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh, & lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh, & corrlengthnh,corrlengthtr,corrlengthsh, & obtimelnh,obtimeltr,obtimelsh,letkf_flag, & @@ -292,6 +293,8 @@ subroutine read_ob_sens lnsigl(nob) = latval(deglat,lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh) else if (obtype(nob)(1:3) == ' ps') then lnsigl(nob) = latval(deglat,lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh) + else if (obtype(nob)(1:3) == 'fed') then + lnsigl(nob) = latval(deglat,lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh) else lnsigl(nob)=latval(deglat,lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh) end if diff --git a/src/enkf/enkf_obsmod.f90 b/src/enkf/enkf_obsmod.f90 index ea8f6446fb..eb4f9c8e58 100644 --- a/src/enkf/enkf_obsmod.f90 +++ b/src/enkf/enkf_obsmod.f90 @@ -109,6 +109,8 @@ module enkf_obsmod lnsigcutoffnh, lnsigcutoffsh, lnsigcutofftr, corrlengthnh,& corrlengthtr, corrlengthsh, obtimelnh, obtimeltr, obtimelsh,& lnsigcutoffsatnh, lnsigcutoffsatsh, lnsigcutoffsattr,& + lnsigcutofffednh, lnsigcutofffedsh, lnsigcutofffedtr,& + corrlengthfednh, corrlengthfedtr, corrlengthfedsh, & varqc, huber, zhuberleft, zhuberright, modelspace_vloc, & lnsigcutoffpsnh, lnsigcutoffpssh, lnsigcutoffpstr, neigv, & lnsigcutoffrdrnh, lnsigcutoffrdrsh, lnsigcutoffrdrtr,& @@ -276,6 +278,8 @@ subroutine readobs() lnsigl(nob) = latval(deglat,lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh) else if (obtype(nob)(1:3) == ' ps') then lnsigl(nob) = latval(deglat,lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh) + else if (obtype(nob)(1:3) == 'fed') then + lnsigl(nob) = latval(deglat,lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh) else if ( (obtype(nob)(1:3) == 'dbz' .or. obtype(nob)(1:3) == ' rw') .and. l_use_enkf_directZDA ) then lnsigl(nob) = latval(deglat,lnsigcutoffrdrnh,lnsigcutoffrdrtr,lnsigcutoffrdrsh) else @@ -293,6 +297,9 @@ subroutine readobs() if ( (obtype(nob)(1:3) == 'dbz' .or. obtype(nob)(1:3) == ' rw') .and. l_use_enkf_directZDA ) then corrlengthsq(nob)=latval(deglat,corrlengthrdrnh,corrlengthrdrtr,corrlengthrdrsh)**2 end if + if (obtype(nob)(1:3) == 'fed') then + corrlengthsq(nob)=latval(deglat,corrlengthfednh,corrlengthfedtr,corrlengthfedsh)**2 + end if obtimel(nob)=latval(deglat,obtimelnh,obtimeltr,obtimelsh) end do diff --git a/src/enkf/innovstats.f90 b/src/enkf/innovstats.f90 index 68668218fc..853532c9b9 100644 --- a/src/enkf/innovstats.f90 +++ b/src/enkf/innovstats.f90 @@ -45,6 +45,7 @@ subroutine print_innovstats(obfit,obsprd) nobsspd_nh,nobsspd_sh,nobsspd_tr,& nobsgps_nh,nobsgps_sh,nobsgps_tr,& nobsdbz_nh,nobsdbz_sh,nobsdbz_tr,& + nobsfed_nh,nobsfed_sh,nobsfed_tr,& nobsrw_nh,nobsrw_sh,nobsrw_tr,& nobsq_nh,nobsq_sh,nobsq_tr,nobswnd_nh,nobswnd_sh,nobswnd_tr,& nobsoz_nh,nobsoz_sh,nobsoz_tr,nobsps_sh,nobsps_nh,nobsps_tr,nob @@ -67,6 +68,9 @@ subroutine print_innovstats(obfit,obsprd) sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,& sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,& sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,& + sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,& + sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,& + sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,& sumrw_nh,biasrw_nh,sumrw_spread_nh,sumrw_oberr_nh,& sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,& sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,& @@ -112,6 +116,9 @@ subroutine print_innovstats(obfit,obsprd) nobsdbz_nh = 0 nobsdbz_sh = 0 nobsdbz_tr = 0 + nobsfed_nh = 0 + nobsfed_sh = 0 + nobsfed_tr = 0 nobsrw_nh = 0 nobsrw_sh = 0 nobsrw_tr = 0 @@ -168,6 +175,12 @@ subroutine print_innovstats(obfit,obsprd) sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,& sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr) + else if (obtype(nob)(1:3) == 'fed') then + call obstats(obfit(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,nobsfed_nh,& + sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,nobsfed_sh,& + sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,nobsfed_tr) else if (obtype(nob)(1:3) == ' rw') then call obstats(obfit(nob),oberrvar_orig(nob),& obsprd(nob),obloclat(nob),& @@ -216,6 +229,9 @@ subroutine print_innovstats(obfit,obsprd) call printstats(' all dbz',sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,& sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr) + call printstats(' all fed',sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,nobsfed_nh,& + sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,nobsfed_sh,& + sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,nobsfed_tr) call printstats(' all rw',sumrw_nh,biasq_nh,sumrw_spread_nh,sumrw_oberr_nh,nobsrw_nh,& sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,nobsrw_sh,& sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,nobsrw_tr) diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index 62701c24a7..36b0c9c207 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -124,6 +124,8 @@ module params real(r_single),public :: lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,& lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh +real(r_single),public :: corrlengthfednh,corrlengthfedtr,corrlengthfedsh, & + lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh real(r_single),public :: corrlengthrdrnh,corrlengthrdrtr,corrlengthrdrsh, & lnsigcutoffrdrnh,lnsigcutoffrdrtr,lnsigcutoffrdrsh real(r_single),public :: analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,saterrfact @@ -261,6 +263,8 @@ module params lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,& lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh,& + corrlengthfednh,corrlengthfedsh,corrlengthfedtr,& + lnsigcutofffednh,lnsigcutofffedsh,lnsigcutofffedtr,& fgfileprefixes,fgsfcfileprefixes,anlfileprefixes, & anlsfcfileprefixes,incfileprefixes,incsfcfileprefixes,& statefileprefixes,statesfcfileprefixes, & @@ -317,6 +321,10 @@ subroutine read_namelist() corrlengthrdrnh = 10 corrlengthrdrtr = 10 corrlengthrdrsh = 10 +! corrlength (km) for GLM flash extent density +corrlengthfednh = 30_r_single +corrlengthfedtr = 30_r_single +corrlengthfedsh = 30_r_single ! read in localization length scales from an external file. readin_localization = .false. ! min and max inflation. @@ -341,6 +349,9 @@ subroutine read_namelist() lnsigcutoffrdrnh = 0.2_r_single ! value for radar lnsigcutoffrdrtr = 0.2_r_single ! value for radar lnsigcutoffrdrsh = 0.2_r_single ! value for radar +lnsigcutofffednh = 2._r_single ! value for GLM flash extent density +lnsigcutofffedtr = 2._r_single ! value for GLM flash extent density +lnsigcutofffedsh = 2._r_single ! value for GLM flash extent density ! ob time localization obtimelnh = 1.e10_r_single obtimeltr = 1.e10_r_single @@ -813,6 +824,10 @@ subroutine read_namelist() corrlengthrdrnh = corrlengthrdrnh * 1.e3_r_single/rearth corrlengthrdrtr = corrlengthrdrtr * 1.e3_r_single/rearth corrlengthrdrsh = corrlengthrdrsh * 1.e3_r_single/rearth +! rescale covariance localization length for GLM FED +corrlengthfednh = corrlengthfednh * 1.e3_r_single/rearth +corrlengthfedtr = corrlengthfedtr * 1.e3_r_single/rearth +corrlengthfedsh = corrlengthfedsh * 1.e3_r_single/rearth ! convert targe area boundary into radians tar_minlat = tar_minlat * deg2rad diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index d1f4ec3ff8..a5383069a1 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -42,9 +42,9 @@ module readconvobs !> observation types to read from netcdf files -integer(i_kind), parameter :: nobtype = 11 +integer(i_kind), parameter :: nobtype = 12 character(len=3), dimension(nobtype), parameter :: obtypes = (/' t', ' q', ' ps', ' uv', 'tcp', & - 'gps', 'spd', ' pw', ' dw', ' rw', 'dbz' /) + 'gps', 'spd', ' pw', ' dw', ' rw', 'dbz', 'fed' /) contains @@ -79,7 +79,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id integer(i_kind) :: iunit, nchar, nreal, ii, mype, ios, idate, i, ipe, ioff0 integer(i_kind),dimension(2) :: nn,nobst, nobsps, nobsq, nobsuv, nobsgps, & nobstcp,nobstcx,nobstcy,nobstcz,nobssst, nobsspd, nobsdw, nobsrw, nobspw, & - nobsdbz + nobsdbz, nobsfed character(8),allocatable,dimension(:):: cdiagbuf real(r_single),allocatable,dimension(:,:)::rdiagbuf real(r_kind) :: errorlimit,errorlimit2,error,pres,obmax @@ -104,6 +104,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id nobspw = 0 nobsgps = 0 nobsdbz = 0 + nobsfed = 0 nobstcp = 0; nobstcx = 0; nobstcy = 0; nobstcz = 0 init_pass = .true. peloop: do ipe=0,npefiles @@ -187,6 +188,9 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id else if (obtype == 'dbz') then nobsdbz = nobsdbz + nn num_obs_tot = num_obs_tot + nn(2) + else if (obtype == 'fed') then + nobsfed = nobsfed + nn + num_obs_tot = num_obs_tot + nn(2) else if (obtype == 'gps') then nobsgps = nobsgps + nn num_obs_tot = num_obs_tot + nn(2) @@ -231,6 +235,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id write(6,100) 'dw',nobsdw(1),nobsdw(2) write(6,100) 'rw',nobsrw(1),nobsrw(2) write(6,100) 'dbz',nobsdbz(1),nobsdbz(2) + write(6,100) 'fed',nobsfed(1),nobsfed(2) write(6,100) 'tcp',nobstcp(1),nobstcp(2) if (nobstcx(2) .gt. 0) then write(6,100) 'tcx',nobstcx(1),nobstcx(2) @@ -1075,6 +1080,7 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & if (obtype == ' t' .or. obtype == ' uv' .or. obtype == ' ps' .or. & obtype == 'tcp' .or. obtype == ' q' .or. obtype == 'spd' .or. & obtype == 'sst' .or. obtype == ' rw' .or. obtype == 'dbz' .or. & + obtype == 'fed' .or. & obtype == 'gps' .or. obtype == ' dw' .or. obtype == ' pw') then ! direct reflectivitiy DA has a different routine for dbz obs.