diff --git a/ci/spack.yaml b/ci/spack.yaml index eeb9f95512..a831de16ad 100644 --- a/ci/spack.yaml +++ b/ci/spack.yaml @@ -18,7 +18,7 @@ spack: - nemsio@2.5.2 - wrf-io@1.2.0 - ncio@1.1.2 - - crtm@2.3.0 + - crtm@2.4.0 - gsi-ncdiag@1.0.0 view: true concretizer: diff --git a/fix b/fix index 0be26971f8..6a42a29dbb 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 0be26971f834fe9b1d5b118e1e0ffed53facf671 +Subproject commit 6a42a29dbbc9fca3453cc9e829601185555890b9 diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua index dbdf347bf7..fc2d34d7bb 100644 --- a/modulefiles/gsi_common.lua +++ b/modulefiles/gsi_common.lua @@ -14,7 +14,7 @@ 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.3.0" +local crtm_ver=os.getenv("crtm_ver") or "2.4.0" local ncdiag_ver=os.getenv("ncdiag_ver") or "1.0.0" load(pathJoin("netcdf", netcdf_ver)) diff --git a/modulefiles/gsi_gaea b/modulefiles/gsi_gaea index 91089895a1..641f3d0fcf 100644 --- a/modulefiles/gsi_gaea +++ b/modulefiles/gsi_gaea @@ -52,9 +52,6 @@ module load sigio-intel-sandybridge/2.0.1 module load sp-intel-sandybridge/2.0.2 module load w3nco-intel-sandybridge/2.0.6 module load w3emc-intel-sandybridge/2.2.0 -module load crtm-intel/2.2.4 -#setenv CRTM_INC /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/crtm/v2.2.4/intel/include/crtm_v2.2.4 -#setenv CRTM_LIB /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/crtm/v2.2.4/intel/libcrtm_v2.2.4.a module load bacio-intel-sandybridge/2.0.2 setenv CRAYOS_VERSION $::env(CRAYPE_VERSION) #setenv CRAYOS_VERSION ${CRAYPE_VERSION} diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index 3ed9fbddb0..4f0253ba4d 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("MKLROOT", "/apps/oneapi/mkl/2022.0.2") -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230601") whatis("Description: GSI environment on Hera with GNU Compilers") diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index 7557bd9678..35fa4b748f 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -26,6 +26,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230601") whatis("Description: GSI environment on Hera with Intel Compilers") diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua index ddb255bc1f..a769deca6f 100644 --- a/modulefiles/gsi_jet.lua +++ b/modulefiles/gsi_jet.lua @@ -1,26 +1,32 @@ help([[ ]]) -load("cmake/3.20.1") +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/hpc-stack/libs/intel-18.0.5.274/modulefiles/stack") -prepend_path("MODULEPATH", "/contrib/anaconda/modulefiles") +local hpc_ver=os.getenv("hpc_ver") or "1.2.0" +local hpc_intel_ver=os.getenv("hpc_intel_ver") or "18.0.5.274" +local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2018.4.274" +local cmake_ver=os.getenv("cmake_ver") or "3.20.1" +local anaconda_ver=os.getenv("anaconda_ver") or "5.3.1" +local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load("anaconda/5.3.1") +load(pathJoin("hpc", hpc_ver)) +load(pathJoin("hpc-intel", hpc_intel_ver)) +load(pathJoin("hpc-impi", hpc_impi_ver)) +load(pathJoin("cmake", cmake_ver)) -prepend_path("MODULEPATH", "/lfs4/HFIP/hfv3gfs/nwprod/hpc-stack/libs/modulefiles/stack") +prepend_path("MODULEPATH", "/contrib/anaconda/modulefiles") -load("hpc/1.1.0") -load("hpc-intel/18.0.5.274") -load("hpc-impi/2018.4.274") +load(pathJoin("anaconda", anaconda_ver)) load("gsi_common") -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" 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", "/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20221128") + +pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20230601") whatis("Description: GSI environment on Jet with Intel Compilers") diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.lua index 792f7ac8bc..b329dd054f 100644 --- a/modulefiles/gsi_orion.lua +++ b/modulefiles/gsi_orion.lua @@ -23,6 +23,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230601") whatis("Description: GSI environment on Orion with Intel Compilers") diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.lua index f393ce516a..24b1f5962d 100644 --- a/modulefiles/gsi_s4.lua +++ b/modulefiles/gsi_s4.lua @@ -23,6 +23,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-march=ivybridge") pushenv("FFLAGS", "-march=ivybridge") -pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20230601") whatis("Description: GSI environment on S4 with Intel Compilers") diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.lua index 84ffce874a..1872f89d17 100644 --- a/modulefiles/gsi_wcoss2.lua +++ b/modulefiles/gsi_wcoss2.lua @@ -19,16 +19,7 @@ load(pathJoin("python", python_ver)) load(pathJoin("prod_util", prod_util_ver)) load("gsi_common") -unload("ncio") -unload("ncdiag") -pushenv("HPC_OPT", "/apps/ops/para/libs") -prepend_path("MODULEPATH", "/apps/ops/para/libs/modulefiles/compiler/intel/19.1.3.304") -prepend_path("MODULEPATH", "/apps/ops/para/libs/modulefiles/mpi/intel/19.1.3.304/cray-mpich/8.1.7") - -load("ncio/1.1.2") -load("ncdiag/1.0.0") - -pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230601") whatis("Description: GSI environment on WCOSS2") diff --git a/regression/global_3dvar.sh b/regression/global_3dvar.sh index 145cb6212c..56f78ad384 100755 --- a/regression/global_3dvar.sh +++ b/regression/global_3dvar.sh @@ -294,7 +294,7 @@ for type in $listdiag; do date=`echo $diag_file | cut -d'.' -f2` $UNCOMPRESS $diag_file fnameanl=$(echo $fname|sed 's/_ges//g') - mv $fname.$date $fnameanl + mv ${fname}.${date} $fnameanl done # Run GSI diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh index db5ecb920a..747794fae0 100755 --- a/regression/netcdf_fv3_regional.sh +++ b/regression/netcdf_fv3_regional.sh @@ -7,15 +7,6 @@ set -x # Set experiment name exp=$jobname -#TM=00 -#TM2=03 -#tmmark=tm${TM} - - -# Set path/file for gsi executable -#gsiexec=/meso/save/Wanshu.Wu/Code/trunk/trunk_40320/src/global_gsi_org -#gsiexec=/da/save/Michael.Lueken/trunk/src/global_gsi.x - # Set runtime and save directories tmpdir=$tmpdir/tmpreg_netcdf_fv3_regional/${exp} savdir=$savdir/outreg_netcdf_fv3_regional/${exp} diff --git a/regression/regression_param.sh b/regression/regression_param.sh index a2808ddfc0..6024dbdb54 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -53,8 +53,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:50:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:50:00" ; popts[2]="12/9/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:30:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -123,8 +123,8 @@ case $regtest in 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:35:00" ; popts[1]="6/8/" ; ropts[1]="/1" - topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" elif [[ "$machine" = "Discover" ]]; then topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" @@ -153,8 +153,8 @@ case $regtest in 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" = "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]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/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" @@ -255,8 +255,8 @@ case $regtest in 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:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15: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]="16/2/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 250317f405..05b5563ef1 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -33,7 +33,7 @@ if [[ -d /glade ]]; then # Cheyenne export machine="Cheyenne" elif [[ -d /scratch1 ]]; then # Hera export machine="Hera" -elif [[ -d /jetmon ]]; then # Jet +elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; then # Jet export machine="Jet" elif [[ -d /discover ]]; then # NCCS Discover export machine="Discover" @@ -58,7 +58,6 @@ case $machine in fi export ptmp="/glade/scratch/$LOGNAME/$ptmpName" - export fixcrtm="/glade/p/ral/jntp/tools/crtm/2.2.3/fix_update" export casesdir="/glade/p/ral/jntp/tools/CASES" export check_resource="no" @@ -99,7 +98,6 @@ case $machine in fi export ptmp="${ptmp:-/work/noaa/stmp/$LOGNAME/$ptmpName}" - export fixcrtm=${CRTM_FIX:-/apps/contrib/NCEPLIBS/orion/fix/crtm_v2.3.0} export casesdir="/work/noaa/da/rtreadon/CASES/regtest" export check_resource="no" @@ -124,7 +122,6 @@ case $machine in export ptmp="${ptmp:-/scratch1/NCEPDEV/stmp2/$LOGNAME/$ptmpName}" -## export fixcrtm="${CRTM_FIX:-/scratch1/NCEPDEV/da/Michael.Lueken/CRTM_REL-2.2.3/crtm_v2.2.3/fix_update}" export casesdir="/scratch1/NCEPDEV/da/Russ.Treadon/CASES/regtest" export check_resource="no" @@ -138,19 +135,16 @@ case $machine in export noscrub=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/noscrub export ptmp=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp - export fixcrtm="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CRTM_REL-2.2.3/crtm_v2.2.3/fix_update" - export casesdir="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CASES" + export casesdir="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CASES/regtest" export check_resource="no" export accnt="nesdis-rdo2" export group="global" export queue="batch" if [[ "$cmaketest" = "false" ]]; then - export basedir="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/gsi" + export basedir="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/save/git/gsi" fi - export ptmp="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp/$ptmpName" - # On Jet, there are no scrubbers to remove old contents from stmp* directories. # After completion of regression tests, will remove the regression test subdirecories export clean=".true." @@ -163,7 +157,6 @@ case $machine in export ptmp=$basedir export ptmp=$basedir export noscrub=$basedir - export fixcrtm="/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/gsi/etc/fix_ncep20170329/REL-2.2.3-r60152_local-rev_1/CRTM_Coeffs/$endianness" export casesdir="/discover/nobackup/projects/gmao/obsdev/wrmccart/NCEP_regression/CASES" export check_resource="no" export accnt="g0613" @@ -176,18 +169,6 @@ case $machine in ;; esac -if [[ "$cmaketest" = "false" ]]; then - export builddir=$noscrub/build - export gsisrc="$basedir/$updat/src" - export gsiexec_updat="$gsisrc/global_gsi.x" - export gsiexec_contrl="$basedir/$contrl/src/global_gsi.x" - export enkfexec_updat="$gsisrc/enkf/global_enkf.x" - export enkfexec_contrl="$basedir/$contrl/src/enkf/global_enkf.x" - export fixgsi="$basedir/$updat/fix" - export scripts="$basedir/$updat/regression" - export ush="$basedir/$updat/ush" -fi - # We are dealing with *which* endian files export endianness="Big_Endian" diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90 index bb2421c89c..4aa2613c63 100644 --- a/src/enkf/controlvec.f90 +++ b/src/enkf/controlvec.f90 @@ -131,7 +131,7 @@ subroutine init_controlvec() cvars3d(nc3d) = trim(adjustl(var)) clevels(nc3d) = ilev + clevels(nc3d-1) else - if (nproc .eq. 0) print *,'Error: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev + if (nproc .eq. 0) print *,'Error controlvec: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev call stop2(503) endif enddo @@ -212,7 +212,10 @@ subroutine read_control() ! read in whole control vector on i/o procs - keep in memory ! (needed in write_ensemble) allocate(grdin(npts,ncdim,nbackgrounds,nanals_per_iotask)) -allocate(qsat(npts,nlevs,nbackgrounds,nanals_per_iotask)) +! if only updating the sfc fields, qsat will not be calculated in readgriddata +! only allocate if needed. +q_ind = getindex(cvars3d, 'q') +if (q_ind > 0) allocate(qsat(npts,nlevs,nbackgrounds,nanals_per_iotask)) if (paranc) then if (nproc == 0) t1 = mpi_wtime() call readgriddata_pnc(cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, & @@ -225,7 +228,8 @@ subroutine read_control() fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat) end if !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat) - if (use_qsatensmean) then + q_ind = getindex(cvars3d, 'q') + if (use_qsatensmean .and. q_ind>0 ) then allocate(qsatmean(npts,nlevs,nbackgrounds)) allocate(qsat_tmp(npts)) ! compute ensemble mean qsat @@ -257,7 +261,6 @@ subroutine read_control() ! print *,'min/max qsatmean proc',nproc,'=',& ! minval(qsatmean(:,:,nbackgrounds/2+1)),maxval(qsatmean(:,:,nbackgrounds/2+1)) !endif - q_ind = getindex(cvars3d, 'q') if (pseudo_rh .and. q_ind > 0) then if (use_qsatensmean) then do ne=1,nanals_per_iotask diff --git a/src/enkf/enkf.f90 b/src/enkf/enkf.f90 index c117e4ba56..d35613b585 100644 --- a/src/enkf/enkf.f90 +++ b/src/enkf/enkf.f90 @@ -97,6 +97,12 @@ module enkf ! used to be the same) and the "chunks" come from loadbal ! 2018-05-31: whitaker: add modulated ensemble model-space vertical ! localization (neigv>0) and denkf option. +! 2022-04-01: Y. Wang and X. Wang: Add dbz_ind related if-blocks to fix spurious +! analysis increments due to some unstable amplifying behaviors near edges of +! strong precipitation when clear air and large reflectivity values are +! assimilated in locations near each other (as may be the case in the leading +! line of an MCS). +! poc: xuguang.wang@ou.edu ! ! attributes: ! language: f95 @@ -182,7 +188,7 @@ subroutine enkf_update() integer(i_kind) ierr ! kd-tree search results type(kdtree2_result),dimension(:),allocatable :: sresults1,sresults2 -integer(i_kind) nanal,nn,nnn,nobm,nsame,nn1,nn2,oz_ind,nlev +integer(i_kind) nanal,nn,nnn,nobm,nsame,nn1,nn2,oz_ind,nlev,dbz_ind real(r_single),dimension(nlevs_pres):: taperv logical lastiter, kdgrid, kdobs @@ -609,6 +615,7 @@ subroutine enkf_update() nn2 = ncdim end if if (nf2 > 0) then + dbz_ind = getindex(cvars3d, 'dbz') !$omp parallel do schedule(dynamic,1) private(ii,i,nb,obt,nn,nnn,nlev,lnsig,kfgain,ens_tmp,taper1,taper3,taperv) do ii=1,nf2 ! loop over nearby horiz grid points do nb=1,nbackgrounds ! loop over background time levels @@ -628,8 +635,13 @@ subroutine enkf_update() ! (through hpfhtcon) kfgain=taper1*sum(ens_tmp*anal_obtmp_modens) ! update mean. - ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + & - kfgain*obinc_tmp + if ( (nn >= (dbz_ind-1)*nlevs+1 .and. nn <= (dbz_ind-1)*nlevs+nlevs) )then + ensmean_chunk(i,nn,nb) = max(ensmean_chunk(i,nn,nb) + & + kfgain*obinc_tmp,zero) + else + ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + & + kfgain*obinc_tmp + end if ! update perturbations. anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + & kfgain*obganl(:) @@ -652,7 +664,11 @@ subroutine enkf_update() ! (through hpfhtcon) kfgain=taperv(nnn)*sum(anal_chunk(:,i,nn,nb)*anal_obtmp) ! update mean. - ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp + if ( (nn >= (dbz_ind-1)*nlevs+1 .and. nn <= (dbz_ind-1)*nlevs+nlevs) )then + ensmean_chunk(i,nn,nb) = max(ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp,zero) + else + ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp + end if ! update perturbations. anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + kfgain*obganl(:) end if @@ -681,7 +697,13 @@ subroutine enkf_update() taper(obt*obtimelinv)* & sum(anal_obchunk_modens(:,nob2)*anal_obtmp_modens)*hpfhtcon ! update mean. - ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + nob3 = indxproc_obs(nproc+1,nob2) + if(trim(obtype(nob3)) == 'dbz' ) then + ensmean_obchunk(nob2) = max((ensmean_obchunk(nob2) + & + kfgain*obinc_tmp),zero) + else + ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + end if ! update perturbations. anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl anal_obchunk_modens(:,nob2) = anal_obchunk_modens(:,nob2) + kfgain*obganl_modens @@ -707,7 +729,13 @@ subroutine enkf_update() taper(lnsig*lnsiglinv)*taper(obt*obtimelinv)* & sum(anal_obchunk(:,nob2)*anal_obtmp)*hpfhtcon ! update mean. - ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + nob3 = indxproc_obs(nproc+1,nob2) + if(trim(obtype(nob3)) == 'dbz' ) then + ensmean_obchunk(nob2) = max((ensmean_obchunk(nob2) + & + kfgain*obinc_tmp),zero) + else + ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + end if ! update perturbations. anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl ! recompute ob space spread ratio for unassimlated obs @@ -758,6 +786,7 @@ subroutine enkf_update() tend = mpi_wtime() if (nproc .eq. 0) then write(6,8003) niter,'timing on proc',nproc,' = ',tend-tbegin,t2,t3,t4,t5,t6,nrej + if(allocated(assimltd_flag))deallocate(assimltd_flag) allocate(assimltd_flag(nobstot)) assimltd_flag = 99999 if (iassim_order == 2) then diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90 index ef5b242901..4eff63c003 100644 --- a/src/enkf/gridinfo_fv3reg.f90 +++ b/src/enkf/gridinfo_fv3reg.f90 @@ -72,10 +72,10 @@ module gridinfo integer(i_kind),public :: npts integer(i_kind),public :: ntrunc ! supported variable names in anavinfo -character(len=max_varname_length),public, dimension(15) :: & +character(len=max_varname_length),public, dimension(16) :: & vars3d_supported = [character(len=max_varname_length) :: & 'u', 'v', 'w', 't', 'q', 'oz', 'cw', 'tsen', 'prse', & - 'ql', 'qi', 'qr', 'qs', 'qg', 'qnr'] + 'ql', 'qi', 'qr', 'qs', 'qg', 'qnr','dbz'] character(len=max_varname_length),public, dimension(3) :: & vars2d_supported = [character(len=max_varname_length) :: & 'ps', 'pst', 'sst'] diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90 index c2e2b10f57..317ca2221c 100644 --- a/src/enkf/gridinfo_gfs.f90 +++ b/src/enkf/gridinfo_gfs.f90 @@ -66,7 +66,7 @@ module gridinfo ! supported variable names in anavinfo character(len=max_varname_length),public, dimension(13) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'oz ', 'cw ', 'tsen', 'prse', & 'ql ', 'qi ', 'qr ', 'qs ', 'qg '/) -character(len=max_varname_length),public, dimension(3) :: vars2d_supported = (/'ps ', 'pst', 'sst' /) +character(len=max_varname_length),public, dimension(13) :: vars2d_supported = (/'ps ', 'pst', 'sst', 't2m', 'q2m', 'st1', 'st2', 'st3', 'st4', 'sl1', 'sl2', 'sl3', 'sl4' /) ! supported variable names in anavinfo contains diff --git a/src/enkf/gridio_fv3reg.f90 b/src/enkf/gridio_fv3reg.f90 index fb23a21a0c..068e6cba8b 100644 --- a/src/enkf/gridio_fv3reg.f90 +++ b/src/enkf/gridio_fv3reg.f90 @@ -24,6 +24,8 @@ module gridio ! -- add code to update 'delp' directly ! from analysis icnrements ! 2022-06- Ting -- Implement paranc=.true. for fv3-lam + ! 2022-04-01 Yongming Wang and X. Wang: Add interface for read in dBZ + ! poc: xuguang.wang@ou.edu ! attributes: ! language: f95 ! @@ -40,7 +42,7 @@ module gridio use params, only: nlevs, cliptracers, datapath, arw, nmm, datestring use params, only: nx_res,ny_res,nlevs,ntiles,l_fv3reg_filecombined,& fv3_io_layout_nx,fv3_io_layout_ny,nanals - use params, only: pseudo_rh, l_use_enkf_directZDA + use params, only: pseudo_rh use mpeu_util, only: getindex use read_fv3regional_restarts,only:read_fv3_restart_data1d,read_fv3_restart_data2d use read_fv3regional_restarts,only:read_fv3_restart_data3d,read_fv3_restart_data4d @@ -60,17 +62,19 @@ module gridio !------------------------------------------------------------------------- - integer(i_kind) ,parameter:: ndynvarslist=6, ntracerslist=8 + integer(i_kind) ,parameter:: ndynvarslist=6, ntracerslist=8, nphysicslist=1 character(len=max_varname_length), parameter, dimension(ndynvarslist) :: & vardynvars = [character(len=max_varname_length) :: & 'u', 'v', 'T', 'W', 'DZ', 'delp'] character(len=max_varname_length), parameter, dimension(ntracerslist) :: & vartracers = [character(len=max_varname_length) :: & 'sphum','o3mr', 'liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc'] + character(len=max_varname_length), parameter, dimension(nphysicslist) :: & + varphysics = [character(len=max_varname_length) :: 'ref_f3d'] type type_fv3lamfile logical l_filecombined - character(len=max_varname_length), dimension(2):: fv3lamfilename - integer (i_kind), dimension(2):: fv3lam_fileid(2) + character(len=max_varname_length), dimension(3):: fv3lamfilename + integer (i_kind), dimension(3):: fv3lam_fileid contains procedure, pass(this) :: setupfile => type_bound_setupfile procedure, pass(this):: get_idfn => type_bound_getidfn @@ -104,9 +108,9 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, ! Define local variables character(len=500) :: filename - character(len=:),allocatable :: fv3filename,fv3filename1 + character(len=:),allocatable :: fv3filename,fv3filename1,fv3filename2 character(len=7) :: charnanal - integer(i_kind) file_id,file_id1 + integer(i_kind) file_id,file_id1,file_id2 real(r_single), dimension(:,:,:), allocatable ::workvar3d,uworkvar3d,& vworkvar3d,tvworkvar3d,tsenworkvar3d,& workprsi,qworkvar3d @@ -124,6 +128,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, integer(i_kind) :: nlevsp1 integer (i_kind):: i,j, k,nn,ntile,nn_tile0, nb,nanal,ne integer(i_kind) :: u_ind, v_ind, tv_ind,tsen_ind, q_ind, oz_ind + integer(i_kind) :: dbz_ind integer(i_kind) :: w_ind, ql_ind, qi_ind, qr_ind, qs_ind, qg_ind, qnr_ind integer (i_kind):: ps_ind, sst_ind integer (i_kind):: tmp_ind,ifile @@ -147,6 +152,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, qs_ind = getindex(vars3d, 'qs') ! Q snow (3D) qg_ind = getindex(vars3d, 'qg') ! Q graupel (3D) qnr_ind = getindex(vars3d, 'qnr') ! N rain (3D) + dbz_ind = getindex(vars3d, 'dbz') ! Reflectivity (3D) ps_ind = getindex(vars2d, 'ps') ! Ps (2D) sst_ind = getindex(vars2d, 'sst') ! SST (2D) @@ -191,9 +197,19 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, fv3filename1=trim(adjustl(filename))//"_tracer" call nc_check( nf90_open(trim(adjustl(fv3filename1)),nf90_nowrite,file_id1),& myname_,'open: '//trim(adjustl(fv3filename1)) ) - call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & - fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)) ) - + if(dbz_ind > 0) then + fv3filename2=trim(adjustl(filename))//"_phyvar" + call nc_check(nf90_open(trim(adjustl(fv3filename2)),nf90_nowrite,file_id2),& + myname_,'open: '//trim(adjustl(fv3filename2)) ) + endif + if(dbz_ind > 0) then + call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & + fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)),& + fileid3=file_id2,fv3fn3=trim(adjustl(fv3filename2))) + else + call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & + fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1))) + endif endif !---------------------------------------------------------------------- @@ -476,6 +492,27 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, endif + if (dbz_ind > 0) then + varstrname = 'ref_f3d' + call fv3lamfile%get_idfn(varstrname,file_id,fv3filename) + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + vargrid(nn,levels(dbz_ind-1)+k,nb,ne)=max(workvar3d(i,j,nlevs+1-k),0.0_r_kind) + enddo + enddo + enddo + do k = levels(dbz_ind-1)+1, levels(dbz_ind) + if (nproc .eq. 0) & + write(6,*) 'READFVregional : dbz ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + + endif + ! set SST to zero for now if (sst_ind > 0) then vargrid(:,levels(n3d)+sst_ind,nb,ne) = zero @@ -549,7 +586,8 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, call nc_check( nf90_close(file_id),& myname_,'close '//trim(filename) ) else - do ifile=1,2 + do ifile=1,3 + if(dbz_ind <= 0 .and. ifile == 3) cycle file_id=fv3lamfile%fv3lam_fileid(ifile) filename=fv3lamfile%fv3lamfilename(ifile) call nc_check( nf90_close(file_id),& @@ -601,15 +639,15 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid !---------------------------------------------------------------------- ! Define variables computed within subroutine character(len=500) :: filename - character(len=:),allocatable :: fv3filename,fv3filename1 + character(len=:),allocatable :: fv3filename,fv3filename1,fv3filename2 character(len=7) :: charnanal !---------------------------------------------------------------------- - integer(i_kind) :: u_ind, v_ind, tv_ind, tsen_ind,q_ind, ps_ind,oz_ind - integer(i_kind) :: w_ind + integer(i_kind) :: u_ind, v_ind, tv_ind, tsen_ind,q_ind, ps_ind,oz_ind,dbz_ind + integer(i_kind) :: w_ind, cw_ind, ph_ind integer(i_kind) :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind, qnr_ind - integer(i_kind) file_id,file_id1 + integer(i_kind) file_id,file_id1,file_id2 real(r_single), dimension(:,:), allocatable ::pswork real(r_single), dimension(:,:,:), allocatable ::workvar3d,workinc3d,workinc3d2,uworkvar3d,& vworkvar3d,tvworkvar3d,tsenworkvar3d,& @@ -652,10 +690,11 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid qs_ind = getindex(vars3d, 'qs') ! QS (3D) for FV3 qg_ind = getindex(vars3d, 'qg') ! QG (3D) for FV3 qnr_ind = getindex(vars3d, 'qnr') ! QNR (3D) for FV3 + dbz_ind = getindex(vars3d, 'dbz') ! Reflectivity (3D) ps_ind = getindex(vars2d, 'ps') ! Ps (2D) - + clip=tiny(clip) !---------------------------------------------------------------------- if (nbackgrounds > 1) then write(6,*)'gridio/writegriddata: writing multiple backgrounds not yet supported' @@ -699,6 +738,15 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)) ) + if(dbz_ind > 0) then + call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & + fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)),& + fileid3=file_id2,fv3fn3=trim(adjustl(fv3filename2))) + else + call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & + fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1))) + endif + endif @@ -805,6 +853,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid varstrname = 'sphum' call fv3lamfile%get_idfn(varstrname,file_id,fv3filename) call read_fv3_restart_data3d(varstrname,fv3filename,file_id,qworkvar3d) + !enforce lower positive bound (clip) to replace negative hydrometers + if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip tvworkvar3d=tsenworkvar3d*(one+fv*qworkvar3d) tvworkvar3d=tvworkvar3d+workinc3d if(q_ind > 0) then @@ -818,6 +868,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo qworkvar3d=qworkvar3d+workinc3d + !enforce lower positive bound (clip) to replace negative q + if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip endif tsenworkvar3d=tvworkvar3d/(one+fv*qworkvar3d) varstrname = 'T' @@ -884,10 +936,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -907,10 +956,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -930,10 +976,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -953,10 +996,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -976,10 +1016,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -998,10 +1035,26 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip + call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + + endif + + if (dbz_ind > 0) then + varstrname = 'ref_f3d' + call fv3lamfile%get_idfn(varstrname,file_id,fv3filename) + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + workinc3d(i,j,nlevs+1-k)=vargrid(nn,levels(dbz_ind-1)+k,nb,ne) + enddo + enddo + enddo + workvar3d=workvar3d+workinc3d + where (workvar3d < 0.0_r_kind) workvar3d = 0.0_r_kind call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -1051,7 +1104,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid call nc_check( nf90_close(file_id),& myname_,'close '//trim(filename) ) else - do ifile=1,2 + do ifile=1,3 + if(dbz_ind <=0 .and. ifile == 3) cycle file_id=fv3lamfile%fv3lam_fileid(ifile) filename=fv3lamfile%fv3lamfilename(ifile) call nc_check( nf90_close(file_id),& @@ -1820,7 +1874,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat ps_ind = getindex(vars2d, 'ps') ! Ps (2D) - + clip=tiny(clip) allocate(my_neb(4)) !---------------------------------------------------------------------- if (nbackgrounds > 1) then @@ -2105,6 +2159,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo if(iope ==0 ) then + if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip tvworkvar3d=tsenworkvar3d*(one+fv*qworkvar3d) tvworkvar3d=tvworkvar3d+workinc3d if(q_ind > 0) then @@ -2118,6 +2173,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo qworkvar3d=qworkvar3d+workinc3d + if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip endif tsenworkvar3d=tvworkvar3d/(one+fv*qworkvar3d) endif @@ -2213,10 +2269,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2247,10 +2300,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2281,10 +2331,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2315,10 +2362,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2349,10 +2393,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2382,10 +2423,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2478,19 +2516,23 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat ! Return calculated values return end subroutine writegriddata_pnc -subroutine type_bound_setupfile(this,fileid1,fv3fn1,fileid2,fv3fn2) +subroutine type_bound_setupfile(this,fileid1,fv3fn1,fileid2,fv3fn2,fileid3,fv3fn3) implicit none class (type_fv3lamfile) :: this integer(i_kind) fileid1 - integer(i_kind), optional :: fileid2 + integer(i_kind), optional :: fileid2,fileid3 character(len=*)::fv3fn1 - character(len=*),optional ::fv3fn2 + character(len=*),optional ::fv3fn2,fv3fn3 if (present (fileid2)) then this%l_filecombined=.false. this%fv3lamfilename(1)=trim(fv3fn1) this%fv3lamfilename(2)=trim(fv3fn2) this%fv3lam_fileid(1)=fileid1 this%fv3lam_fileid(2)=fileid2 + if (present (fileid3)) then + this%fv3lamfilename(3)=trim(fv3fn3) + this%fv3lam_fileid(3)=fileid3 + endif else this%l_filecombined=.true. this%fv3lamfilename(1)=fv3fn1 @@ -2509,6 +2551,9 @@ subroutine type_bound_getidfn(this,vnamloc,fileid,fv3fn) else if(ifindstrloc(vartracers,vnamloc)> 0) then fv3fn=trim(this%fv3lamfilename(2)) fileid=this%fv3lam_fileid(2) + else if(ifindstrloc(varphysics,vnamloc)> 0) then + fv3fn=trim(this%fv3lamfilename(3)) + fileid=this%fv3lam_fileid(3) else write(6,*)"the varname ",trim(vnamloc)," is not recognized in the ype_bound_getidfn, stop" call stop2(23) diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index fe5199e395..e4631f4e2d 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -35,6 +35,7 @@ module gridio ! a required input for EFSO calculations ! 2019-03-13 Add precipitation components ! 2019-07-10 Add convective clouds +! 2022-07-21 Draper: added read/write for sfc file for nc io (writeincrements, and readgridata) ! ! attributes: ! language: f95 @@ -100,12 +101,21 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & logical ice logical use_full_hydro integer(i_kind), allocatable, dimension(:) :: mem_pe, lev_pe1, lev_pe2, iocomms - integer(i_kind) :: iope, ionumproc, iolevs, krev + integer(i_kind) :: iope, ionumproc, iolevs, krev, ierr integer(i_kind) :: ncstart(3), nccount(3) ! mpi gatherv things integer(i_kind), allocatable, dimension(:) :: recvcounts, displs real(r_single), dimension(nlons,nlats,nlevs) :: ug3d_0, vg3d_0 + logical :: read_sfc_file, read_atm_file + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file) + + if (read_sfc_file) then + print *,'paranc not supported for reading surface files' + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) + endif ! figure out what member to read and do MPI sub-communicator things allocate(mem_pe(0:numproc-1)) @@ -157,7 +167,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & levdim = get_dim(dset,'pfull'); nlevsin = levdim%len idvc=2 else - print *, 'parallel read only supported for netCDF, stopping with error' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** parallel read only supported for netCDF' , ' PROGRAM STOPS' call stop2(23) end if ice = .false. ! calculate qsat w/resp to ice? @@ -185,6 +195,9 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & sst_ind = getindex(vars2d, 'sst') use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. & qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 ) + ! Currently, we do not let precipiation to affect the enkf analysis + ! The following line will be removed after testing + use_full_hydro = .false. if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) @@ -195,7 +208,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & call read_vardata(dset, 'pressfc', values_2d,errcode=iret) if (iret /= 0) then - print *,'error reading ps' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading ps, iret= ',iret,' PROGRAM STOPS' call stop2(31) endif psg = 0.01_r_kind*reshape(values_2d,(/nlons*nlats/)) @@ -215,12 +228,12 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & call read_vardata(dset, 'ugrd', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading ugrd' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading ugrd, iret= ',iret,' PROGRAM STOPS' call stop2(22) endif call read_vardata(dset, 'vgrd', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading vgrd' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading vgrd, iret= ',iret,' PROGRAM STOPS' call stop2(23) endif call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& @@ -247,12 +260,12 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & end if call read_vardata(dset,'tmp', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading tmp' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading tmp, iret= ',iret,' PROGRAM STOPS' call stop2(24) endif call read_vardata(dset,'spfh', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading spfh' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading spfh, iret= ',iret,' PROGRAM STOPS' call stop2(25) endif call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& @@ -276,7 +289,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & if (oz_ind > 0) then call read_vardata(dset, 'o3mr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading o3mr' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading o3mr, iret= ',iret,' PROGRAM STOPS' call stop2(26) endif if (cliptracers) where (ug3d < clip) ug3d = clip @@ -290,31 +303,122 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & end do end if endif - if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then - call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) - if (iret /= 0) then - print *,'error reading clwmr' - call stop2(27) + ! Read in hydrometeor fields based on control/state variables listed in anavinfo table + if (use_full_hydro) then + if(ql_ind > 0) then + call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(ql_ind-1)+k,nb,ne)) + end do + end if endif - if (imp_physics == 11) then - call read_vardata(dset, 'icmr', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if(qi_ind > 0) then + call read_vardata(dset, 'icmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading icmr' - call stop2(28) + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(qi_ind-1)+k,nb,ne)) + end do + end if + endif + if(qr_ind > 0) then + call read_vardata(dset, 'rwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading rwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(26) endif - ug3d = ug3d + vg3d + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(qr_ind-1)+k,nb,ne)) + end do + end if + endif + if(qs_ind > 0) then + call read_vardata(dset, 'snmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading snmr, iret= ',iret,' PROGRAM STOPS' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(qs_ind-1)+k,nb,ne)) + end do + end if + endif + if(qg_ind > 0) then + call read_vardata(dset, 'grle', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading grle, iret= ',iret,' PROGRAM STOPS' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(qg_ind-1)+k,nb,ne)) + end do + end if + endif + else + ! Handle non-precipiting hydrometeors + ! if control or state variable is cw, make sure combine background ql and qi to cw + if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then + call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(27) + endif + if (imp_physics == 11) then + call read_vardata(dset, 'icmr', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS' + call stop2(28) + endif + ug3d = ug3d + vg3d + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,cw(:,k)) + if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k) + end do + end if endif - if (cliptracers) where (ug3d < clip) ug3d = clip - call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& - mpi_real4, 0, iocomms(mem_pe(nproc)),iret) - if (iope==0) then - do k=1,nlevs - krev = nlevs-k+1 - ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) - call copytogrdin(ug,cw(:,k)) - if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k) - end do - end if endif deallocate(ug3d,vg3d) @@ -355,22 +459,25 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & end if ! cloud derivatives + ! Currently, we do not let precipiation to affect the enkf analysis + ! The following line will be removed after testing + use_full_hydro = .true. if (.not. use_full_hydro .and. iope==0) then - if (ql_ind > 0 .or. qi_ind > 0) then - do k=1,nlevs - do i = 1, npts - qi_coef = -r0_05*(tv(i,k)/(one+fv*q(i,k))-t0c) - qi_coef = max(zero,qi_coef) - qi_coef = min(one,qi_coef) ! 0<=qi_coef<=1 - if (ql_ind > 0) then - grdin(i,levels(ql_ind-1)+k,nb,ne) = cw(i,k)*(one-qi_coef) - endif - if (qi_ind > 0) then - grdin(i,levels(qi_ind-1)+k,nb,ne) = cw(i,k)*qi_coef - endif + if (ql_ind > 0 .or. qi_ind > 0) then + do k=1,nlevs + do i = 1, npts + qi_coef = -r0_05*(tv(i,k)/(one+fv*q(i,k))-t0c) + qi_coef = max(zero,qi_coef) + qi_coef = min(one,qi_coef) ! 0<=qi_coef<=1 + if (ql_ind > 0) then + grdin(i,levels(ql_ind-1)+k,nb,ne) = cw(i,k)*(one-qi_coef) + endif + if (qi_ind > 0) then + grdin(i,levels(qi_ind-1)+k,nb,ne) = cw(i,k)*qi_coef + endif + enddo enddo - enddo - endif + endif endif if (sst_ind > 0 .and. iope==0) then @@ -457,7 +564,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, type(sigio_head) :: sighead type(sigio_data) :: sigdata type(nemsio_gfile) :: gfile - type(Dataset) :: dset + type(Dataset) :: dset, dset_sfc type(Dimension) :: londim,latdim,levdim type(nemsio_gfile) :: gfilesfc @@ -465,14 +572,20 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, integer(i_kind) :: qr_ind, qs_ind, qg_ind integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind integer(i_kind) :: ps_ind, pst_ind, sst_ind + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind + integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind integer(i_kind) :: k,iunitsig,iret,nb,i,idvc,nlonsin,nlatsin,nlevsin,ne,nanal integer(i_kind) :: nlonsin_sfc,nlatsin_sfc logical ice logical use_full_hydro + logical read_sfc_file, read_atm_file use_full_hydro = .false. + ! determine which files will be read in + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file) + ne = 0 ensmemloop: do nanal=nanal1,nanal2 ne = ne + 1 @@ -565,6 +678,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, ! print *, 'ql: ', ql_ind, ', prse: ', prse_ind ! print *, 'ps: ', ps_ind, ', pst: ', pst_ind, ', sst: ', sst_ind ! endif + if (read_atm_file) then if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) @@ -634,7 +748,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, pressi(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*psg if (nanal .eq. 1) print *,'netcdf, min/max pressi',k,minval(pressi(:,k)),maxval(pressi(:,k)) enddo - deallocate(ak,bk,values_2d) + deallocate(ak,bk) else vrtspec = sigdata%ps call sptez_s(vrtspec,psg,1) @@ -1003,10 +1117,134 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, deallocate(pressi,pslg) deallocate(psg) if (pst_ind > 0) deallocate(vmassdiv,pstend) + endif ! read_atm_file + if (use_gfs_nemsio) call nemsio_close(gfile,iret=iret) if (use_gfs_ncio) call close_dataset(dset) if (use_gfs_nemsio) call nemsio_close(gfilesfc,iret=iret) + if ( read_sfc_file ) then + + if ( .not. use_gfs_ncio ) then + write(6,*) 'griddio/griddata for sfc update vars only coded for nc io' + call stop2(23) + endif + if ( reducedgrid ) then + write(6,*) "reducedgrid=T interpolation not valid for writing sfc files" + call stop2(22) + endif + + ! land sfc DA variables + tmp2m_ind = getindex(vars2d, 't2m') + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + dset_sfc = open_dataset(filenamesfc) + ! read in sfc vars, if requested + if (tmp2m_ind > 0) then + call read_vardata(dset_sfc, 'tmp2m', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading tmp2m' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + tmp2m_ind,nb,ne)) + endif + if (spfh2m_ind > 0) then + call read_vardata(dset_sfc, 'spfh2m', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading spfh2m' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + spfh2m_ind,nb,ne)) + endif + if (soilt1_ind > 0) then + call read_vardata(dset_sfc, 'soilt1', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading soilt1' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + soilt1_ind,nb,ne)) + endif + if (soilt2_ind > 0) then + call read_vardata(dset_sfc, 'soilt2', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading soilt2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + soilt2_ind,nb,ne)) + endif + if (soilt3_ind > 0) then + call read_vardata(dset_sfc, 'soilt3', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading soilt3' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + soilt3_ind,nb,ne)) + endif + if (soilt4_ind > 0) then + call read_vardata(dset_sfc, 'soilt4', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading soilt2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne)) + endif + if (slc1_ind > 0) then + call read_vardata(dset_sfc, 'slc1', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading slc1' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + slc1_ind,nb,ne)) + endif + if (slc2_ind > 0) then + call read_vardata(dset_sfc, 'slc2', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading slc2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + slc2_ind,nb,ne)) + endif + if (slc3_ind > 0) then + call read_vardata(dset_sfc, 'slc3', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading slc3' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + slc3_ind,nb,ne)) + endif + if (slc4_ind > 0) then + call read_vardata(dset_sfc, 'slc4', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading slc2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + slc4_ind,nb,ne)) + endif + + call close_dataset(dset_sfc) + + endif ! sfc read + + if ( allocated(values_2d) ) deallocate(values_2d) + end do backgroundloop ! loop over backgrounds to read in end do ensmemloop ! loop over ens members to read in @@ -1901,6 +2139,15 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n integer k,krev,nt,ierr,iunitsig,nb,i,ne,nanal logical :: nocompress + logical :: write_sfc_file, write_atm_file + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) + + if (write_sfc_file .and. nproc==0 ) then + ! adding the sfc increments requires adjusting several other variables. This is done is a separate + ! program. + write(6,*)'gridio/writegriddata: not coded to write sfc analysis, use separate add_incr program instead' + endif nocompress = .true. if (nccompress) nocompress = .false. @@ -3305,7 +3552,7 @@ end subroutine writegriddata subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) use netcdf use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,& - datestring,nhr_anal,write_ensmean + datestring,nhr_anal,write_ensmean, fgsfcfileprefixes,incsfcfileprefixes use constants, only: grav use mpi use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& @@ -3341,7 +3588,12 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & - tvarid, sphumvarid, liqwatvarid, o3varid, icvarid + tvarid, sphumvarid, liqwatvarid, o3varid, icvarid, & + tmp2mvarid, spfh2mvarid, soilt1varid, soilt2varid, & + soilt3varid, soilt4varid, slc1varid, slc2varid, & + slc3varid, slc4varid, maskvarid + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind, & + soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind integer(i_kind) :: iadateout ! fixed fields such as lat, lon, levs @@ -3353,10 +3605,17 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ! increment real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout + real(r_single), allocatable, dimension(:,:) :: inc2d, inc2dout real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl real(r_kind), allocatable, dimension(:,:) :: values_2d real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d + ! soil / snow mask (not fixed) + integer(i_kind), dimension(nlons,nlats) :: mask + logical :: write_sfc_file, write_atm_file + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) + if ( write_atm_file) then use_full_hydro = .false. clip = tiny_r_kind read(datestring,*) iadateout @@ -3677,14 +3936,267 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & start = ncstart, count = nccount)) + call close_dataset(dsfg,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writeincrement gfs model: problem closing netcdf fg dataset, iret=',iret + call stop2(23) + endif ! deallocate things deallocate(inc3d,inc3d2,inc3dout) deallocate(tmp,tv,q,tmpanl,tvanl,qanl) - deallocate(delzb,psges) + if (allocated(delzb)) deallocate(delzb) + if (allocated(psges)) deallocate(psges) end do backgroundloop ! loop over backgrounds to read in end do ensmemloop ! loop over ens members to read in + endif ! write_atm_file + + if (write_sfc_file) then + + ne = 0 + sfcensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 + write(charnanal,'(i3.3)') nanal + sfcbackgroundloop: do nb=1,nbackgrounds + + if (nanal == 0 .and. write_ensmean) then + filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"ensmean" + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"ensmean" + else + if(no_inflate_flag) then + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"nimem"//charnanal + else + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"mem"//charnanal + end if + filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"mem"//charnanal + endif + + ! create the output netCDF increment file + call nccheck_incr(nf90_create(path=trim(filenameout), cmode=nf90_netcdf4, ncid=ncid_out)) + + ! create dimensions based on analysis resolution, not guess + call nccheck_incr(nf90_def_dim(ncid_out, "longitude", nlons, lon_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "latitude", nlats, lat_dimid)) + ! create variables + call nccheck_incr(nf90_def_var(ncid_out, "longitude", nf90_real, (/lon_dimid/), lonvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "latitude", nf90_real, (/lat_dimid/), latvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids3(1:2), tmp2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids3(1:2), spfh2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids3(1:2), soilt1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids3(1:2), soilt2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids3(1:2), soilt3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids3(1:2), soilt4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids3(1:2), slc1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids3(1:2), slc2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids3(1:2), slc3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids3(1:2), slc4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int, dimids3(1:2), maskvarid)) + ! place global attributes to serial calc_increment output + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & + "global landsfc anal increment from writeincrement")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time", iadateout)) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "IAU_hour_from_guess", nhr_anal(nb))) + ! add units to lat/lon because that's what the calc_increment utility has + call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units", "degrees_east")) + call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units", "degrees_north")) + ! end the netCDF file definition + call nccheck_incr(nf90_enddef(ncid_out)) + + tmp2m_ind = getindex(vars2d, 't2m') !< indices in the state or control var arrays + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + dsfg = open_dataset(filenamein) + + ! longitudes + call read_vardata(dsfg, 'grid_xt', values_1d, errcode=iret) + deglons(:) = values_1d + call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, & + start = (/1/), count = (/nlons/))) + + call read_vardata(dsfg, 'grid_yt', values_1d, errcode=iret) + ! latitudes + do j=1,nlats + deglats(nlats-j+1) = values_1d(j) + end do + + call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, & + start = (/1/), count = (/nlats/))) + + ! construct mask (1 - soil, 2 - snow, 0 - not snow) + ! note: same logic/threshold used in global_cycle to produce + ! mask on model grid. + + call read_vardata(dsfg, 'slc1', values_2d, errcode=iret) + + mask = 0 + do j=1,nlats + do i = 1, nlons + if (values_2d(i,j) .LT. 1.0) then + mask(i,nlats-j+1) = 1 + endif + enddo + end do + + call read_vardata(dsfg, 'weasd', values_2d, errcode=iret) + do j=1,nlats + do i = 1, nlons + if (values_2d(i,j) .GT. 0.001) then + mask(i,nlats-j+1) = 2 + endif + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, maskvarid, mask, & + start = ncstart(1:2), count = nccount(1:2))) + + allocate(inc2d(nlons,nlats)) + allocate(inc2dout(nlons,nlats)) + + ! tmp2m increment + inc(:) = zero + if (tmp2m_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + tmp2m_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, tmp2mvarid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! spfh2m increment + inc(:) = zero + if (spfh2m_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+spfh2m_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, spfh2mvarid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt1 increment + inc(:) = zero + if (soilt1_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt1_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt1varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt2 increment + inc(:) = zero + if (soilt2_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt2_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt2varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt3 increment + inc(:) = zero + if (soilt3_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt3_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt3varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt4 increment + inc(:) = zero + if (soilt4_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt4_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt4varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc1 increment + inc(:) = zero + if (slc1_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc1_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc1varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc2 increment + inc(:) = zero + if (slc2_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc2_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc2varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc3 increment + inc(:) = zero + if (slc3_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc3_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc3varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc4 increment + inc(:) = zero + if (slc4_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc4_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc4varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + + call close_dataset(dsfg,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writeincrement gfs model: problem closing netcdf sfc fg dataset, iret=',iret + call stop2(23) + endif + ! deallocate things + deallocate(inc2d,inc2dout) + + end do sfcbackgroundloop ! loop over backgrounds to read in + end do sfcensmemloop ! loop over ens members to read in + + endif ! write_sfc_file + return contains @@ -3709,7 +4221,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate use netcdf use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,& datestring,nhr_anal - use constants, only: grav + use constants, only: grav,qcmin use mpi use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& read_attribute, close_dataset, get_dim, read_vardata,& @@ -3744,7 +4256,8 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & - tvarid, sphumvarid, liqwatvarid, o3varid, icvarid + tvarid, sphumvarid, liqwatvarid, o3varid, icvarid, & + rwmrvarid, snmrvarid, grlevarid integer(i_kind) :: iadateout ! fixed fields such as lat, lon, levs @@ -3757,6 +4270,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl + real(r_single), allocatable, dimension(:,:,:) :: q2, qanl2 real(r_kind), allocatable, dimension(:,:) :: values_2d real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d @@ -3846,6 +4360,12 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate call nccheck_incr(nf90_var_par_access(ncid_out, o3varid, nf90_collective)) call nccheck_incr(nf90_def_var(ncid_out, "icmr_inc", nf90_real, dimids3, icvarid)) call nccheck_incr(nf90_var_par_access(ncid_out, icvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "rwmr_inc", nf90_real, dimids3, rwmrvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, rwmrvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "snmr_inc", nf90_real, dimids3, snmrvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, snmrvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "grle_inc", nf90_real, dimids3, grlevarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, grlevarid, nf90_collective)) ! place global attributes to parallel calc_increment output call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & @@ -3878,7 +4398,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate dsfg = open_dataset(filenamein, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) call read_attribute(dsfg, 'ak', values_1d,errcode=iret) if (iret /= 0) then - print *,'error reading ak' + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading ak, iret= ',iret,' PROGRAM STOPS' call stop2(29) endif do k=1,nlevs+1 @@ -3887,7 +4407,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate enddo call read_attribute(dsfg, 'bk', values_1d,errcode=iret) if (iret /= 0) then - print *,'error reading bk' + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading bk, iret= ',iret,' PROGRAM STOPS' call stop2(29) endif do k=1,nlevs+1 @@ -3997,7 +4517,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate allocate(tvanl(nlons,nlats,nccount(3)),tmpanl(nlons,nlats,nccount(3)),qanl(nlons,nlats,nccount(3))) call read_vardata(dsfg, 'spfh', q, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading spfh' + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading spfh, iret= ',iret,' PROGRAM STOPS' call stop2(29) endif do k=lev_pe1(iope), lev_pe2(iope) @@ -4022,7 +4542,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! t increment call read_vardata(dsfg, 'tmp', tmp, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading tmp' + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading tmp, iret= ',iret,' PROGRAM STOPS' call stop2(29) endif tv = tmp * ( 1.0 + fv*q) @@ -4094,33 +4614,68 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate call nccheck_incr(nf90_put_var(ncid_out, o3varid, sngl(inc3dout), & start = ncstart, count = nccount)) + ! For hydrometeors, following the treatment for specific humidity increment + ! Need to make sure the analysis value is not negative + ! Read in background + increment and make sure the minimum is qcmin + ! Adjust increment accordingly + ! liq wat increment ! icmr increment + ! if cw increment, make sure split the cw increment into ql and qi increments + allocate(q2(nlons,nlats,nccount(3)),qanl2(nlons,nlats,nccount(3))) + call read_vardata(dsfg, 'clwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + call read_vardata(dsfg, 'icmr', q2, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif do k=lev_pe1(iope), lev_pe2(iope) krev = nlevs-k+1 ki = k - lev_pe1(iope) + 1 - ug = zero + ug = zero; vg = zero if (cw_ind > 0) then call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) + else if (ql_ind > 0) then + call copyfromgrdin(grdin(:,levels(ql_ind-1)+krev,nb,ne),ug) end if - if (imp_physics == 11) then - work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c) - do i=1,nlons*nlats - work(i) = max(zero,work(i)) - work(i) = min(one,work(i)) - enddo - vg = ug * work ! cloud ice - ug = ug * (one - work) ! cloud water - inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) + ! analysis control variable is cw, need to split cw analysis to ql and qi + if (cw_ind > 0) then + if (imp_physics == 11) then + work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c) + do i=1,nlons*nlats + work(i) = max(zero,work(i)) + work(i) = min(one,work(i)) + enddo + vg = ug * work ! cloud ice + ug = ug * (one - work) ! cloud water + endif + else if (qi_ind > 0) then + call copyfromgrdin(grdin(:,levels(qi_ind-1)+krev,nb,ne),vg) endif - inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) + inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) ! cloud water + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) ! cloud ice + qanl2(:,:,ki) = q2(:,:,ki) + inc3d(:,:,ki) enddo + + ! adjust hydrometeor increment to make sure analysis is positive + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! ql + if (cliptracers) where (qanl2 < qcmin) qanl2 = qcmin + inc3d2 = qanl2 - q2 ! qi + + ! output ql increment do j=1,nlats inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) end do if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & start = ncstart, count = nccount)) + ! output qi increment do j=1,nlats inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) end do @@ -4128,11 +4683,87 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & start = ncstart, count = nccount)) + ! rwmr increment + call read_vardata(dsfg, 'rwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading rwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qr_ind > 0) then + call copyfromgrdin(grdin(:,levels(qr_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated rwmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('rwmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, rwmrvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! snmr increment + call read_vardata(dsfg, 'snmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading snmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qs_ind > 0) then + call copyfromgrdin(grdin(:,levels(qs_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated snmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('snmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, snmrvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! grle increment + call read_vardata(dsfg, 'grle', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading grle, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qg_ind > 0) then + call copyfromgrdin(grdin(:,levels(qg_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated grle increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('grle_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, grlevarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + call mpi_barrier(iocomms(mem_pe(nproc)), iret) ! deallocate things deallocate(inc3d,inc3d2,inc3dout) deallocate(tmp,tv,q,tmpanl,tvanl,qanl) + deallocate(q2,qanl2) if (allocated(delzb)) deallocate(delzb) if (allocated(psges)) deallocate(psges) @@ -4163,6 +4794,64 @@ end subroutine copyfromgrdin end subroutine writeincrement_pnc + subroutine set_ncio_file_flags(vars3d, n3d, vars2d, n2d, sfc_file, atm_file) + ! determine if variables are in sfc and/or atm file, for ncio case. + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d, n3d + logical, intent(out) :: sfc_file, atm_file + + integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind + integer(i_kind) :: qr_ind, qs_ind, qg_ind + integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind + integer(i_kind) :: ps_ind, pst_ind, sst_ind + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind + integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind + + ! atmos file variables + u_ind = getindex(vars3d, 'u') !< indices in the state or control var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 'tv') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + oz_ind = getindex(vars3d, 'oz') ! Oz (3D) + cw_ind = getindex(vars3d, 'cw') ! CW (3D) + tsen_ind = getindex(vars3d, 'tsen') !sensible T (3D) + ql_ind = getindex(vars3d, 'ql') ! QL (3D) + qi_ind = getindex(vars3d, 'qi') ! QI (3D) + prse_ind = getindex(vars3d, 'prse') + qr_ind = getindex(vars3d, 'qr') ! QR (3D) + qs_ind = getindex(vars3d, 'qs') ! QS (3D) + qg_ind = getindex(vars3d, 'qg') ! QG (3D) + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + pst_ind = getindex(vars2d, 'pst') ! Ps tendency (2D) // equivalent of + ! old logical massbal_adjust, if non-zero + sst_ind = getindex(vars2d, 'sst') ! is this really in the atmos file? + + ! for nc gfs io determine if requested variables are in sfc and/or atmos file + atm_file = ( u_ind>0 .or. v_ind>0 .or. tv_ind>0 .or. q_ind>0 .or. sst_ind>0 .or. & + oz_ind>0 .or. cw_ind>0 .or. tsen_ind>0 .or. ql_ind>0 .or. & + qi_ind>0 .or. prse_ind>0 .or. qr_ind>0 .or. qs_ind>0 .or. qg_ind>0 ) + + ! sfc file variables + tmp2m_ind = getindex(vars2d, 't2m') + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + sfc_file = ( tmp2m_ind > 0 .or. spfh2m_ind > 0 .or. soilt1_ind > 0 .or. & + slc1_ind > 0 .or. soilt2_ind > 0 .or. slc2_ind > 0 .or. & + soilt3_ind > 0 .or. slc3_ind > 0 .or. soilt4_ind > 0 .or. & + slc4_ind > 0 ) + + end subroutine set_ncio_file_flags + + logical function checkfield(field,fields,nrec) result(hasfield) use nemsio_module, only: nemsio_charkind integer, intent(in) :: nrec diff --git a/src/enkf/innovstats.f90 b/src/enkf/innovstats.f90 index e67cf43f10..68668218fc 100644 --- a/src/enkf/innovstats.f90 +++ b/src/enkf/innovstats.f90 @@ -213,7 +213,7 @@ subroutine print_innovstats(obfit,obsprd) call printstats(' all gps',sumgps_nh,biasq_nh,sumgps_spread_nh,sumgps_oberr_nh,nobsgps_nh,& sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,nobsgps_sh,& sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,nobsgps_tr) - call printstats(' all dbz',sumdbz_nh,biasq_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& + 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 rw',sumrw_nh,biasq_nh,sumrw_spread_nh,sumrw_oberr_nh,nobsrw_nh,& diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index 593e5a5ec4..b21d88abd0 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -85,7 +85,9 @@ module params character(len=120),dimension(7),public :: statefileprefixes character(len=120),dimension(7),public :: statesfcfileprefixes character(len=120),dimension(7),public :: anlfileprefixes +character(len=120),dimension(7),public :: anlsfcfileprefixes character(len=120),dimension(7),public :: incfileprefixes +character(len=120),dimension(7),public :: incsfcfileprefixes ! analysis date string (YYYYMMDDHH) character(len=10), public :: datestring ! Hour for datestring @@ -266,7 +268,7 @@ module params lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh,& fgfileprefixes,fgsfcfileprefixes,anlfileprefixes, & - incfileprefixes, & + anlsfcfileprefixes,incfileprefixes,incsfcfileprefixes,& statefileprefixes,statesfcfileprefixes, & covl_minfact,covl_efold,lupd_obspace_serial,letkf_novlocal,& analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,& @@ -460,8 +462,8 @@ subroutine read_namelist() ! Initialize first-guess and analysis file name prefixes. ! (blank means use default names) fgfileprefixes = ''; anlfileprefixes=''; statefileprefixes='' -fgsfcfileprefixes = ''; statesfcfileprefixes='' -incfileprefixes = '' +anlsfcfileprefixes=''; fgsfcfileprefixes = ''; statesfcfileprefixes='' +incfileprefixes = ''; incsfcfileprefixes = '' ! option for including convective clouds in the all-sky cnvw_option=.false. @@ -720,7 +722,7 @@ subroutine read_namelist() endif endif if (trim(fgsfcfileprefixes(nbackgrounds+1)) .eq. "") then - fgsfcfileprefixes(nbackgrounds+1)="sfgsfc_"//datestring//"_fhr"//charfhr_anal(nbackgrounds+1)//"_" + fgsfcfileprefixes(nbackgrounds+1)="bfg_"//datestring//"_fhr"//charfhr_anal(nbackgrounds+1)//"_" end if nbackgrounds = nbackgrounds+1 end do @@ -742,7 +744,7 @@ subroutine read_namelist() endif endif if (trim(statesfcfileprefixes(nstatefields+1)) .eq. "") then - statesfcfileprefixes(nstatefields+1)="sfgsfc_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_" + statesfcfileprefixes(nstatefields+1)="bfg_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_" end if nstatefields = nstatefields+1 end do @@ -762,6 +764,23 @@ subroutine read_namelist() incfileprefixes(nb)="incr_"//datestring//"_fhr"//charfhr_anal(nb)//"_" ! else ! anlfileprefixes(nb)="sanl_"//datestring//"_" +! endif + endif + endif + if (trim(anlsfcfileprefixes(nb)) .eq. "") then + ! default analysis file prefix + if (regional) then + if (nbackgrounds > 1) then + anlsfcfileprefixes(nb)="sfc_analysis_fhr"//charfhr_anal(nb)//"." + else + anlsfcfileprefixes(nb)="sfc_analysis." + endif + else ! global +! if (nbackgrounds > 1) then + anlsfcfileprefixes(nb)="banl_"//datestring//"_fhr"//charfhr_anal(nb)//"_" + incsfcfileprefixes(nb)="sfcincr_"//datestring//"_fhr"//charfhr_anal(nb)//"_" +! else +! anlfileprefixes(nb)="sanl_"//datestring//"_" ! endif endif endif diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index e1977298a6..d1f4ec3ff8 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -24,6 +24,7 @@ module readconvobs ! reflectivity and radial velocity assimilation. POC: xuguang.wang@ou.edu ! 2017-12-13 shlyaeva - added netcdf diag read/write capability ! 2019-03-21 CAPS(C. Tong) - added direct reflectivity DA capability +! 2022-03-23 draper - added option to not scale qobs by forecast qsat. ! ! attributes: ! language: f95 @@ -32,7 +33,8 @@ module readconvobs use kinds, only: r_kind,i_kind,r_single,r_double use constants, only: one,zero,deg2rad -use params, only: npefiles, netcdf_diag, modelspace_vloc, l_use_enkf_directZDA +use params, only: npefiles, netcdf_diag, modelspace_vloc, & + l_use_enkf_directZDA implicit none private @@ -329,7 +331,6 @@ subroutine get_num_convobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) call nc_diag_read_close(obsfile) - num_obs_totdiag = num_obs_totdiag + nobs_curr do i = 1, nobs_curr @@ -789,6 +790,9 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & x_obs(nob) = x_obs(nob) /Forecast_Saturation_Spec_Hum(i) hx_mean(nob) = hx_mean(nob) /Forecast_Saturation_Spec_Hum(i) hx_mean_nobc(nob) = hx_mean_nobc(nob) /Forecast_Saturation_Spec_Hum(i) + if (neigv>0) then + hx_modens(:,nob) = hx_modens(:,nob)/ Forecast_Saturation_Spec_Hum(i) + endif endif ! for wind, also read v-component diff --git a/src/enkf/statevec.f90 b/src/enkf/statevec.f90 index d1be91af3c..5ad70346aa 100644 --- a/src/enkf/statevec.f90 +++ b/src/enkf/statevec.f90 @@ -14,7 +14,7 @@ module statevec ! ! Public Variables: ! nanals: (integer scalar) number of ensemble members (from module params) -! nlevs: number of analysis vertical levels (from module params). +! nlevs: number of analysis atmos vertical levels (from module params). ! ns3d: number of 3D variables ! ns2d: number of 2D variables ! svars3d: names of 3D variables @@ -120,7 +120,7 @@ subroutine init_statevec() svars3d(ns3d)=trim(adjustl(var)) slevels(ns3d)=ilev + slevels(ns3d-1) else - if (nproc .eq. 0) print *,'Error: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev + if (nproc .eq. 0) print *,'Error statevec: - only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev call stop2(503) endif enddo diff --git a/src/gsi/adjtest.f90 b/src/gsi/adjtest.f90 index d910d14f12..e1a5da7d07 100644 --- a/src/gsi/adjtest.f90 +++ b/src/gsi/adjtest.f90 @@ -33,10 +33,12 @@ module adjtest use control_vectors, only: control_vector,allocate_cv,random_cv, & deallocate_cv,dot_product,assignment(=) use state_vectors, only: allocate_state,deallocate_state,dot_product +use gridmod, only : minmype use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) use bias_predictors, only: predictors,allocate_preds,deallocate_preds, & assignment(=) +use control2state_mod, only: control2state,c2sset,control2state_ad implicit none private @@ -81,7 +83,7 @@ subroutine adtest(xhat) integer(i_kind) :: ii,idig real(r_kind) :: zz1,zz2,zz3 -if (mype==0) write(6,*)'ADTEST starting' +if (mype==minmype) write(6,*)'ADTEST starting' ! ---------------------------------------------------------------------- ! Allocate local variables @@ -97,10 +99,10 @@ subroutine adtest(xhat) ! Initialize control space vectors if (present(xhat)) then xtest1=xhat - if (mype==0) write(6,*)'ADTEST use input xhat' + if (mype==minmype) write(6,*)'ADTEST use input xhat' else call random_cv(xtest1) - if (mype==0) write(6,*)'ADTEST use random_cv(xhat)' + if (mype==minmype) write(6,*)'ADTEST use random_cv(xhat)' endif xtest2=zero @@ -135,18 +137,20 @@ subroutine adtest(xhat) do ii=1,nsubwin zz2=zz2+dot_product(stest1(ii),stest1(ii)) enddo -DO ii=1,nrclen +do ii=1,nrclen zz2=zz2+sbias1%values(ii)*sbias1%values(ii) -ENDDO +enddo -if ( abs(zz1+zz2) > sqrt(tiny(zz3)) ) then - zz3=two*abs(zz1-zz2)/(zz1+zz2) -else - zz3=abs(zz1-zz2) -endif -idig= int(-log(zz3+tiny(zz3))/log(10.0_r_kind)) +if (mype==minmype) then + if ( abs(zz1+zz2) > sqrt(tiny(zz3)) ) then + zz3=two*abs(zz1-zz2)/(zz1+zz2) + else + zz3=abs(zz1-zz2) + end if + idig= int(-log(zz3+tiny(zz3))/log(10.0_r_kind)) -if (mype==0) then +! Note that this result is not completely correct especially on processors +! other than minmype. See issue 548. write(6,'(A)')' ADTEST 0.123456789012345678' write(6,'(A,ES25.18)')' ADTEST = ',zz1 write(6,'(A,ES25.18)')' ADTEST = ',zz2 @@ -166,7 +170,7 @@ subroutine adtest(xhat) call deallocate_preds(sbias2) ! ---------------------------------------------------------------------- -if (mype==0) write(6,*)'ADTEST finished' +if (mype==minmype) write(6,*)'ADTEST finished' return end subroutine adtest diff --git a/src/gsi/adjtest_obs.f90 b/src/gsi/adjtest_obs.f90 index 67e2ff0cdd..294dc32ca0 100644 --- a/src/gsi/adjtest_obs.f90 +++ b/src/gsi/adjtest_obs.f90 @@ -78,6 +78,7 @@ subroutine adtest_obs use m_obsdiags, only: obsLLists use m_obsLList, only: obsLList_getTLDdotprod + use control2state_mod, only: control2state implicit none diff --git a/src/gsi/aeroinfo.f90 b/src/gsi/aeroinfo.f90 index dd8489029b..a030bdeffc 100644 --- a/src/gsi/aeroinfo.f90 +++ b/src/gsi/aeroinfo.f90 @@ -313,12 +313,10 @@ subroutine aeroinfo_read ! Successful read, return to calling routine else -! File does not exist, write warning message to alert users +! File does not exist, write warning message to unit 6 to alert users if (mype==mype_aero) then - open(iout_aero) - write(iout_aero,*)'AEROINFO_READ: ***WARNING*** FILE ',trim(fname),' does not exist' - write(iout_aero,*)'AEROINFO_READ: jpch_aero=',jpch_aero - close(iout_aero) + write(6,*)'AEROINFO_READ: ***WARNING*** FILE ',trim(fname),' does not exist' + write(6,*)'AEROINFO_READ: jpch_aero=',jpch_aero endif end if diff --git a/src/gsi/aircraftinfo.f90 b/src/gsi/aircraftinfo.f90 index b84455f47c..a29f1571b1 100644 --- a/src/gsi/aircraftinfo.f90 +++ b/src/gsi/aircraftinfo.f90 @@ -57,7 +57,7 @@ module aircraftinfo logical :: cleanup_tail ! logical to remove tail number no longer used logical :: upd_aircraft ! indicator if update bias at 06Z & 18Z - integer(i_kind), parameter :: max_tail=10000 ! max tail numbers + integer(i_kind), parameter :: max_tail=100000 ! max tail numbers integer(i_kind) npredt ! predictor number integer(i_kind) ntail ! total tail number integer(i_kind) ntail_update ! new total tail number diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90 index 62c455e011..e97b6fb614 100644 --- a/src/gsi/apply_scaledepwgts.f90 +++ b/src/gsi/apply_scaledepwgts.f90 @@ -42,51 +42,47 @@ subroutine init_mult_spc_wgts(jcap_in) !$$$ end documentation block use kinds, only: r_kind,i_kind,r_single - use hybrid_ensemble_parameters,only: s_ens_hv,sp_loc,grd_ens,grd_loc,sp_ens - use hybrid_ensemble_parameters,only: n_ens,p_sploc2ens,grd_sploc - use hybrid_ensemble_parameters,only: use_localization_grid - use gridmod,only: use_sp_eqspace - use general_specmod, only: general_init_spec_vars - use constants, only: zero,half,one,two,three,rearth,pi - use constants, only: rad2deg + use constants, only: zero,half,one,two,three,rearth,pi,tiny_r_kind use mpimod, only: mype use general_sub2grid_mod, only: general_sub2grid_create_info use egrid2agrid_mod,only: g_create_egrid2agrid use general_sub2grid_mod, only: sub2grid_info - use gsi_io, only: verbose use hybrid_ensemble_parameters, only: nsclgrp - use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params,i_ensloccov4scl + use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params,r_ensloccov4scl implicit none integer(i_kind),intent(in ) :: jcap_in - real(r_kind),allocatable :: totwvlength(:) - integer(i_kind) i,ii,j,k,l,n,kk,nsigend + integer(i_kind) i integer(i_kind) ig real(r_kind) rwv0,rtem1,rtem2 real (r_kind):: fwgtofwvlen - integer(i_kind) :: l_sum_spc_weights + real(r_kind) :: totwvlength + logical :: l_sum_spc_weights ! Spectral scale decomposition is differernt between SDL-cross and SDL-nocross - if( i_ensloccov4scl == 1 )then - l_sum_spc_weights = 1 + if( r_ensloccov4scl < tiny_r_kind )then + l_sum_spc_weights = .false. else - l_sum_spc_weights = 0 + l_sum_spc_weights = .true. end if - allocate(totwvlength(jcap_in)) + spc_multwgt(0,1)=one + do ig=2,nsclgrp + spc_multwgt(0,ig)=zero + end do - rwv0=2*pi*rearth*0.001_r_kind - do i=1,jcap_in - totwvlength(i)= rwv0/real(i) - enddo + + rwv0=2.0_r_kind*pi*rearth*0.001_r_kind do i=1,jcap_in - rtem1=0 + totwvlength= rwv0/real(i) + rtem1=zero do ig=1,nsclgrp if(ig /= 2) then spc_multwgt(i,ig)=fwgtofwvlen(spcwgt_params(1,ig),spcwgt_params(2,ig),& - spcwgt_params(3,ig),spcwgt_params(4,ig),totwvlength(i)) - if(l_sum_spc_weights == 0 ) then + spcwgt_params(3,ig),spcwgt_params(4,ig),totwvlength) + spc_multwgt(i,ig)=min(max(spc_multwgt(i,ig),zero),one) + if(l_sum_spc_weights) then rtem1=rtem1+spc_multwgt(i,ig) else rtem1=rtem1+spc_multwgt(i,ig)*spc_multwgt(i,ig) @@ -94,18 +90,19 @@ subroutine init_mult_spc_wgts(jcap_in) endif enddo rtem2 =1.0_r_kind - rtem1 - if(abs(rtem2) >= zero) then + if(rtem2 >= zero) then - if(l_sum_spc_weights == 0 ) then + if(l_sum_spc_weights) then spc_multwgt(i,2)=rtem2 else spc_multwgt(i,2)=sqrt(rtem2) endif + else + if(mype == 0)write(6,*) ' rtem2 < zero ',i,rtem2,(spc_multwgt(i,ig),ig=1,nsclgrp) + spc_multwgt(i,2)=zero endif enddo - spc_multwgt=max(spc_multwgt,0.0_r_kind) - deallocate(totwvlength) return end subroutine init_mult_spc_wgts @@ -117,18 +114,15 @@ subroutine apply_scaledepwgts(grd_in,sp_in,wbundle,spwgts,wbundle2) ! POC: xuguang.wang@ou.edu ! use constants, only: one - use control_vectors, only: nrf_var,cvars2d,cvars3d,control_vector + use control_vectors, only: control_vector use kinds, only: r_kind,i_kind use kinds, only: r_single - use mpimod, only: mype,nvar_id,levs_id - use hybrid_ensemble_parameters, only: oz_univ_static use general_specmod, only: general_spec_multwgt use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_specmod, only: spec_vars use general_sub2grid_mod, only: sub2grid_info - use mpimod, only: mpi_comm_world,mype,npe,ierror - use file_utility, only : get_lun + use mpimod, only: mpi_comm_world,mype implicit none ! Declare passed variables @@ -139,15 +133,11 @@ subroutine apply_scaledepwgts(grd_in,sp_in,wbundle,spwgts,wbundle2) real(r_kind),dimension(0:sp_in%jcap),intent(in):: spwgts ! Declare local variables - integer(i_kind) ii,kk - integer(i_kind) i,j,lunit + integer(i_kind) kk - real(r_kind),dimension(grd_in%lat2,grd_in%lon2):: slndt,sicet,sst real(r_kind),dimension(grd_in%nlat*grd_in%nlon*grd_in%nlevs_alloc) :: hwork real(r_kind),dimension(grd_in%nlat,grd_in%nlon,grd_in%nlevs_alloc) :: work real(r_kind),dimension(sp_in%nc):: spc1 - character*64 :: fname1 - character*5:: varname1 ! Beta1 first ! Get from subdomains to diff --git a/src/gsi/atms_spatial_average_mod.f90 b/src/gsi/atms_spatial_average_mod.f90 index dd05faa23e..b3e4aafc41 100644 --- a/src/gsi/atms_spatial_average_mod.f90 +++ b/src/gsi/atms_spatial_average_mod.f90 @@ -153,7 +153,7 @@ SUBROUTINE ATMS_Spatial_Average(Num_Obs, NChanl, FOV, Time, BT_InOut, & Scanline_Back(FOV(I),Scanline(I))=I END DO -!$omp parallel do schedule(dynamic,1) private(ichan,iscan,ios,ifov) +!$omp parallel do schedule(dynamic,1) private(i,ichan,iscan,ios,ifov) DO IChan=1,nchanl err(ichan)=0 diff --git a/src/gsi/bicg.f90 b/src/gsi/bicg.f90 index 6eb2f78905..d7ac743d8f 100644 --- a/src/gsi/bicg.f90 +++ b/src/gsi/bicg.f90 @@ -30,7 +30,7 @@ subroutine bicg() use kinds, only: r_kind,i_kind,r_quad use gsi_4dvar, only: l4dvar, & - ladtest, lgrtest, lanczosave, ltcost, nwrvecs + ladtest, lgrtest, lanczosave, ltcost, nwrvecs, lsqrtb use jfunc, only: jiter,miter,niter,xhatsave,yhatsave,jiterstart use constants, only: zero,tiny_r_kind use mpimod, only: mype @@ -39,6 +39,7 @@ subroutine bicg() use obsmod, only: lsaveobsens,l_do_adjoint use adjtest, only: adtest use grdtest, only: grtest +use gsi_bundlemod, only : gsi_bundlegetpointer use control_vectors, only: control_vector use control_vectors, only: allocate_cv,deallocate_cv,write_cv,inquire_cv use control_vectors, only: dot_product,assignment(=) @@ -89,6 +90,13 @@ subroutine bicg() call allocate_cv(gradf) call allocate_cv(grads) +if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if +end if + ! Get initial cost function and gradient nprt=2 diff --git a/src/gsi/bicglanczos.F90 b/src/gsi/bicglanczos.F90 index 1914b0214d..13525e38cb 100755 --- a/src/gsi/bicglanczos.F90 +++ b/src/gsi/bicglanczos.F90 @@ -57,13 +57,14 @@ module bicglanczos use constants, only : zero, one, half,two, zero_quad,tiny_r_kind use timermod , only : timer_ini, timer_fnl use lanczos , only : save_precond -use gsi_4dvar, only : iorthomax +use gsi_4dvar, only : iorthomax,lsqrtb use control_vectors, only: control_vector use control_vectors, only: allocate_cv,deallocate_cv,inquire_cv use control_vectors, only: read_cv,write_cv use control_vectors, only: dot_product,assignment(=) use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) +use gsi_bundlemod, only : gsi_bundlegetpointer use mpimod , only : mpi_comm_world use mpimod, only: mype use jfunc , only : iter, jiter @@ -248,7 +249,13 @@ subroutine pcglanczos(xhat,yhat,pcost,gradx,grady,preduc,kmaxit,lsavevecs) if(nprt>=1.and.ltcost_) call allocate_cv(gradf) call allocate_cv(dirw) -!--- 'zeta' is an upper bound on the relative error of the gradient. +if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if +end if + !--- 'zeta' is an upper bound on the relative error of the gradient. zeta = 1.0e-4_r_kind zreqrd = preduc diff --git a/src/gsi/bkerror.f90 b/src/gsi/bkerror.f90 index b3a0140691..7eb83b09d6 100644 --- a/src/gsi/bkerror.f90 +++ b/src/gsi/bkerror.f90 @@ -71,7 +71,6 @@ subroutine bkerror(grady) ! Declare local variables integer(i_kind) i,ii - integer(i_kind) i_t,i_p,i_st,i_vp integer(i_kind) ipnts(4),istatus ! integer(i_kind) nval_lenz,ndim2d real(r_kind),pointer,dimension(:,:,:):: p_t =>NULL() @@ -97,11 +96,7 @@ subroutine bkerror(grady) ! Only need to get pointer for ii=1 - all other are the same call gsi_bundlegetpointer ( grady%step(1), (/'t ','sf','vp','ps'/), & ipnts, istatus ) - i_t = ipnts(1) - i_st = ipnts(2) - i_vp = ipnts(3) - i_p = ipnts(4) - dobal = i_t>0.and.i_p>0.and.i_st>0.and.i_vp>0 + dobal = ipnts(1)>0 .and. ipnts(2)>0 .and. ipnts(3)>0 .and. ipnts(4)>0 ! if ensemble run, multiply by sqrt_beta_s if(l_hyb_ens) call sqrt_beta_s_mult(grady) diff --git a/src/gsi/calctends_no_tl.f90 b/src/gsi/calctends_no_tl.f90 index 73be86be2e..d4dacb94a5 100644 --- a/src/gsi/calctends_no_tl.f90 +++ b/src/gsi/calctends_no_tl.f90 @@ -244,28 +244,21 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) end if end if -! top/bottom boundary condition: do j=jtstart(kk),jtstop(kk) do i=1,lat2 + +! top/bottom boundary condition: + what(i,j,1)=zero what(i,j,nsig+1)=zero - enddo - enddo - ! load actual dp/dt - do j=jtstart(kk),jtstop(kk) - do i=1,lat2 p_t(i,j)=prsth(i,j,1) - end do - end do ! before big k loop, zero out the km1 summation arrays - do j=jtstart(kk),jtstop(kk) - do i=1,lat2 sumkm1 (i,j)=zero sum2km1 (i,j)=zero sumvkm1 (i,j)=zero diff --git a/src/gsi/compact_diffs.f90 b/src/gsi/compact_diffs.f90 index 14f7b8fdc5..ae03407917 100644 --- a/src/gsi/compact_diffs.f90 +++ b/src/gsi/compact_diffs.f90 @@ -268,7 +268,6 @@ subroutine stvp2uv(work,idim) integer(i_kind) ix,iy integer(i_kind) ny,i,j real(r_kind) polsu,polnu,polnv,polsv - real(r_kind),dimension(nlon):: grid3n,grid3s,grid1n,grid1s real(r_kind),dimension(nlat-2,nlon):: a,b,grid1,grid2,grid3,grid4 if(idim <=1) write(6,*) ' error in call to stvp2uv ',idim @@ -318,27 +317,17 @@ subroutine stvp2uv(work,idim) polnv=polnv/float(nlon) polsu=polsu/float(nlon) polsv=polsv/float(nlon) - do ix=1,nlon - grid3n(ix)= polnu*coslon(ix)+polnv*sinlon(ix) - grid1n(ix)=-polnu*sinlon(ix)+polnv*coslon(ix) - grid3s(ix)= polsu*coslon(ix)+polsv*sinlon(ix) - grid1s(ix)= polsu*sinlon(ix)-polsv*coslon(ix) - end do ! work(1 is u, work(2 is v do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then - work(1,i,j)=grid3(i-1,j) - work(2,i,j)=grid1(i-1,j) - else if(i == 1)then - work(1,i,j)=grid3s(j) - work(2,i,j)=grid1s(j) - else - work(1,i,j)=grid3n(j) - work(2,i,j)=grid1n(j) - end if + do i=2,nlat-1 + work(1,i,j)=grid3(i-1,j) + work(2,i,j)=grid1(i-1,j) end do - enddo + work(1,1,j)= polsu*coslon(j)+polsv*sinlon(j) + work(2,1,j)= polsu*sinlon(j)-polsv*coslon(j) + work(1,nlat,j)= polnu*coslon(j)+polnv*sinlon(j) + work(2,nlat,j)= -polnu*sinlon(j)+polnv*coslon(j) + end do return end subroutine stvp2uv @@ -749,18 +738,14 @@ subroutine tstvp2uv(work,idim) ny=nlat-2 do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then - grid3(i-1,j)=work(1,i,j) - grid1(i-1,j)=work(2,i,j) - else if(i == 1)then - grid3s(j)=work(1,i,j) - grid1s(j)=work(2,i,j) - else - grid3n(j)=work(1,i,j) - grid1n(j)=work(2,i,j) - end if + do i=2,nlat-1 + grid3(i-1,j)=work(1,i,j) + grid1(i-1,j)=work(2,i,j) end do + grid3s(j)=work(1,1,j) + grid1s(j)=work(2,1,j) + grid3n(j)=work(1,nlat,j) + grid1n(j)=work(2,nlat,j) end do polnu=zero @@ -815,16 +800,15 @@ subroutine tstvp2uv(work,idim) nlon,ny,noq) !$omp end parallel sections do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then -! NOTE: Adjoint of first derivative is its negative - work(1,i,j)=-(a(i-1,j)+d(i-1,j)) - work(2,i,j)=-(b(i-1,j)+c(i-1,j)) - else - work(1,i,j)=zero - work(2,i,j)=zero - end if + do i=2,nlat-1 +! NOTE: Adjoint of first derivative is its negative + work(1,i,j)=-(a(i-1,j)+d(i-1,j)) + work(2,i,j)=-(b(i-1,j)+c(i-1,j)) end do + work(1,1,j)=zero + work(2,1,j)=zero + work(1,nlat,j)=zero + work(2,nlat,j)=zero end do return diff --git a/src/gsi/constants.f90 b/src/gsi/constants.f90 index 484e46b8b8..b4cf775068 100644 --- a/src/gsi/constants.f90 +++ b/src/gsi/constants.f90 @@ -90,7 +90,7 @@ module constants ! Declare derived constants integer(i_kind):: huge_i_kind - integer(i_kind), parameter :: max_varname_length=64 + integer(i_kind), parameter :: max_varname_length=20 real(r_single):: tiny_single, huge_single real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90 index fb87c1d0ef..f2d8849ce0 100644 --- a/src/gsi/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -1,3 +1,65 @@ +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !MODULE: control2state_mod --- control2state_mod variables and routines +! +! !INTERFACE: +! +module control2state_mod + +! !USES: + + +! !DESCRIPTION: module control2state routines and variables + +use kinds, only: r_kind,i_kind +use constants, only : max_varname_length, zero +use control_vectors, only: control_vector,c2sset_flg +use control_vectors, only: cvars3d,cvars2d +use bias_predictors, only: predictors +use jfunc, only: nsclen,npclen,ntclen +use gsi_4dvar, only: nsubwin, l4dvar, lsqrtb,ladtest_obs +use gsi_chemguess_mod, only: gsi_chemguess_get +use gsi_metguess_mod, only: gsi_metguess_get +use gsi_bundlemod, only: gsi_bundlegetpointer +use gsi_bundlemod, only: gsi_bundlecreate +use gsi_bundlemod, only: gsi_bundle +use gsi_bundlemod, only: gsi_bundlegetvar +use gsi_bundlemod, only: gsi_bundleputvar +use gsi_bundlemod, only: gsi_bundledestroy +use gsi_bundlemod, only: assignment(=) +use gridmod, only: nems_nmmb_regional +use gridmod, only: regional, twodvar_regional +use gridmod, only: lat2,lon2,nsig,nlat,nlon +use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 +use mpeu_util, only: getindex + +implicit none + +private +public :: do_getprs,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro +public :: do_cw_to_hydro_hwrf,nclouds,ngases +public :: control2state +public :: control2state_ad +public :: c2sset +public :: icpblh,icgust,icvis,icoz,icwspd10m,icw +public :: ictd2m,icmxtm,icmitm,icpmsl,ichowv +public :: icsfwter,icvpwter,ictcamt,iclcbas +public :: iccldch,icuwnd10m,icvwnd10m + +logical :: do_getprs,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro +logical :: do_cw_to_hydro_hwrf + +integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw +integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv +integer(i_kind) :: icsfwter,icvpwter,ictcamt,iclcbas +integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m + +integer :: ngases,nclouds + +contains subroutine control2state(xhat,sval,bval) !$$$ subprogram documentation block ! . . . . @@ -57,31 +119,11 @@ subroutine control2state(xhat,sval,bval) ! bval - Bias predictors ! !$$$ end documentation block -use kinds, only: r_kind,i_kind -use control_vectors, only: control_vector -use control_vectors, only: cvars3d,cvars2d -use bias_predictors, only: predictors -use gsi_4dvar, only: nsubwin, l4dvar, lsqrtb, ladtest_obs -use gridmod, only: regional,lat2,lon2,nsig, nlat, nlon, twodvar_regional -use jfunc, only: nsclen,npclen,ntclen -use cwhydromod, only: cw2hydro_tl use amassaeromod, only: amass2aero_tl -use cwhydromod, only: cw2hydro_tl_hwrf -use gsi_bundlemod, only: gsi_bundlecreate -use gsi_bundlemod, only: gsi_bundle -use gsi_bundlemod, only: gsi_bundlegetpointer -use gsi_bundlemod, only: gsi_bundlegetvar -use gsi_bundlemod, only: gsi_bundleputvar -use gsi_bundlemod, only: gsi_bundledestroy -use gsi_bundlemod, only: assignment(=) -use gsi_chemguess_mod, only: gsi_chemguess_get -use gsi_metguess_mod, only: gsi_metguess_get -use mpeu_util, only: getindex -use constants, only : max_varname_length, zero use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_commvars_mod, only: s2g_cv -use gridmod, only: nems_nmmb_regional -use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 +use cwhydromod, only: cw2hydro_tl +use cwhydromod, only: cw2hydro_tl_hwrf implicit none ! Declare passed variables @@ -94,22 +136,9 @@ subroutine control2state(xhat,sval,bval) character(len=max_varname_length),allocatable,dimension(:) :: gases character(len=max_varname_length),allocatable,dimension(:) :: clouds real(r_kind),dimension(nlat*nlon*s2g_cv%nlevs_alloc) :: hwork -integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz +integer(i_kind) :: ii,jj,ic,id,istatus,istatus_oz type(gsi_bundle):: wbundle ! work bundle -! Note: The following does not aim to get all variables in -! the state and control vectors, but rather the ones -! this routines knows how to handle. -! Declare required local control variables -integer(i_kind), parameter :: ncvars = 9 -integer(i_kind) :: icps(ncvars) -integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw -integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv -integer(i_kind) :: icsfwter,icvpwter,ictcamt,iclcbas -integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m -character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here - 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) -logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() @@ -120,14 +149,6 @@ subroutine control2state(xhat,sval,bval) real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() -! Declare required local state variables -integer(i_kind), parameter :: nsvars = 12 -integer(i_kind) :: isps(nsvars) -character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & - 'qr ', 'qs ', 'qg ', 'qh ' /) -logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi -logical :: ls_qr,ls_qs,ls_qg,ls_qh real(r_kind),pointer,dimension(:,:) :: sv_ps=>NULL(),sv_sst=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_gust=>NULL(),sv_vis=>NULL(),sv_pblh=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_wspd10m=>NULL(),sv_tcamt=>NULL(),sv_lcbas=>NULL() @@ -143,82 +164,17 @@ subroutine control2state(xhat,sval,bval) real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter -logical :: do_getprs_tl,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro -logical :: do_cw_to_hydro_hwrf - - -if (lsqrtb) then - write(6,*)trim(myname),': not for sqrt(B)' - call stop2(106) -end if -if (nsubwin/=1 .and. .not.l4dvar) then - write(6,*)trim(myname),': error 3dvar',nsubwin,l4dvar - call stop2(107) -end if - -! Inquire about cloud-vars -call gsi_metguess_get('clouds::3d',nclouds,istatus) +if (c2sset_flg)call c2sset(xhat,sval) if (nclouds>0) then allocate(clouds(nclouds)) call gsi_metguess_get('clouds::3d',clouds,istatus) end if -! Inquire about chemistry -call gsi_chemguess_get('dim',ngases,istatus) if (ngases>0) then allocate(gases(ngases)) call gsi_chemguess_get('gsinames',gases,istatus) endif -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus) -lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 -lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 -lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 - -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (sval(1),mysvars,isps,istatus) -ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 -ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 -ls_qi =isps(7)>0; ls_w =isps(8)>0 -ls_qr =isps(9)>0; ls_qs =isps(10)>0 -ls_qg =isps(11)>0; ls_qh =isps(12)>0 - -! Define what to do depending on what's in CV and SV -do_getprs_tl =lc_ps.and.lc_t .and.ls_prse -do_normal_rh_to_q=lc_rh.and.lc_t .and.ls_prse.and.ls_q -do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen -do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v - -do_cw_to_hydro=.false. -do_cw_to_hydro_hwrf=.false. -if (regional) then - do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi - do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh -else - do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global -endif - -call gsi_bundlegetpointer (xhat%step(1),'oz',icoz,istatus) -call gsi_bundlegetpointer (xhat%step(1),'gust',icgust,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vis',icvis,istatus) -call gsi_bundlegetpointer (xhat%step(1),'pblh',icpblh,istatus) -call gsi_bundlegetpointer (xhat%step(1),'wspd10m',icwspd10m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'td2m',ictd2m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'mxtm',icmxtm,istatus) -call gsi_bundlegetpointer (xhat%step(1),'mitm',icmitm,istatus) -call gsi_bundlegetpointer (xhat%step(1),'pmsl',icpmsl,istatus) -call gsi_bundlegetpointer (xhat%step(1),'howv',ichowv,istatus) -call gsi_bundlegetpointer (xhat%step(1),'sfwter',icsfwter,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vpwter',icvpwter,istatus) -call gsi_bundlegetpointer (xhat%step(1),'w',icw,istatus) -call gsi_bundlegetpointer (xhat%step(1),'tcamt',ictcamt,istatus) -call gsi_bundlegetpointer (xhat%step(1),'lcbas',iclcbas,istatus) -call gsi_bundlegetpointer (xhat%step(1),'cldch',iccldch,istatus) -call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus) ! Loop over control steps do jj=1,nsubwin @@ -295,7 +251,7 @@ subroutine control2state(xhat,sval,bval) ! Copy other variables call gsi_bundlegetvar ( wbundle, 't' , sv_tv, istatus ) ! Get 3d pressure - if(do_getprs_tl) call getprs_tl(cv_ps,cv_t,sv_prse) + if(do_getprs) call getprs_tl(cv_ps,cv_t,sv_prse) ! Convert input normalized RH to q if(do_normal_rh_to_q) call normal_rh_to_q(cv_rh,cv_t,sv_prse,sv_q) @@ -445,3 +401,471 @@ subroutine control2state(xhat,sval,bval) return end subroutine control2state +subroutine c2sset(xhat,sval) +!$$$ subprogram documentation block +! . . . . +! subprogram: c2sset +! prgmmr: derber +! +! abstract: Sets flags for control2state and control2state_ad +! +! program history log: +! 2022-08-30 derber - initial code from control2state + +! input argument list: +! xhat - Control variable +! sval - State variable +! +!$$$ end documentation block +implicit none + +! Declare passed variables +type(control_vector), intent(in) :: xhat +type(gsi_bundle) , intent(in) :: sval(nsubwin) + +! Declare local variables +character(len=*),parameter::myname='c2sset' +integer(i_kind) :: istatus + +! Note: The following does not aim to get all variables in +! the state and control vectors, but rather the ones +! this routines knows how to handle. +! Declare required local control variables +integer(i_kind), parameter :: ncvars = 9 +integer(i_kind) :: icps(ncvars) +character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here + 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) +logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi + +! Declare required local state variables +integer(i_kind), parameter :: nsvars = 12 +integer(i_kind) :: isps(nsvars) +character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here + 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & + 'qr ', 'qs ', 'qg ', 'qh ' /) +logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi +logical :: ls_qr,ls_qs,ls_qg,ls_qh + + + +if (lsqrtb) then + write(6,*)trim(myname),': not for sqrt(B)' + call stop2(106) +end if +if (nsubwin/=1 .and. .not.l4dvar) then + write(6,*)trim(myname),': error 3dvar',nsubwin,l4dvar + call stop2(107) +end if + +! Inquire about cloud-vars +call gsi_metguess_get('clouds::3d',nclouds,istatus) + +! Inquire about chemistry +call gsi_chemguess_get('dim',ngases,istatus) + +! Since each internal vector of xhat has the same structure, pointers are +! the same independent of the subwindow jj +call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus) +lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 +lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 +lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 + +! Since each internal vector of sval has the same structure, pointers are +! the same independent of the subwindow jj +call gsi_bundlegetpointer (sval(1),mysvars,isps,istatus) +ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 +ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 +ls_qi =isps(7)>0; ls_w =isps(8)>0 +ls_qr =isps(9)>0; ls_qs =isps(10)>0 +ls_qg =isps(11)>0; ls_qh =isps(12)>0 + +! Define what to do depending on what's in CV and SV +do_getprs =lc_ps.and.lc_t .and.ls_prse +do_normal_rh_to_q=lc_rh.and.lc_t .and.ls_prse.and.ls_q +do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen +do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v + +do_cw_to_hydro=.false. +do_cw_to_hydro_hwrf=.false. +if (regional) then + do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi + do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh +else + do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global +endif + +call gsi_bundlegetpointer (xhat%step(1),'oz',icoz,istatus) +call gsi_bundlegetpointer (xhat%step(1),'gust',icgust,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vis',icvis,istatus) +call gsi_bundlegetpointer (xhat%step(1),'pblh',icpblh,istatus) +call gsi_bundlegetpointer (xhat%step(1),'wspd10m',icwspd10m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'td2m',ictd2m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'mxtm',icmxtm,istatus) +call gsi_bundlegetpointer (xhat%step(1),'mitm',icmitm,istatus) +call gsi_bundlegetpointer (xhat%step(1),'pmsl',icpmsl,istatus) +call gsi_bundlegetpointer (xhat%step(1),'howv',ichowv,istatus) +call gsi_bundlegetpointer (xhat%step(1),'sfwter',icsfwter,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vpwter',icvpwter,istatus) +call gsi_bundlegetpointer (xhat%step(1),'w',icw,istatus) +call gsi_bundlegetpointer (xhat%step(1),'tcamt',ictcamt,istatus) +call gsi_bundlegetpointer (xhat%step(1),'lcbas',iclcbas,istatus) +call gsi_bundlegetpointer (xhat%step(1),'cldch',iccldch,istatus) +call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus) + +c2sset_flg=.false. +return +end subroutine c2sset +subroutine control2state_ad(rval,bval,grad) +!$$$ subprogram documentation block +! . . . . +! subprogram: control2state_ad +! prgmmr: tremolet +! +! abstract: Converts variables from physical space to control space +! This is also the adjoint of control2state +! +! program history log: +! 2007-04-16 tremolet - initial code +! 2008-11-28 todling - update to GSI May 2008: add tsen and p3d +! 2009-01-15 todling - handle predictors in quad precision +! 2009-04-21 derber - modify call to getstvp to call to getuv +! 2009-06-15 parrish - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run) +! 2009-08-12 lueken - update documentation +! 2009-11-27 parrish - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp +! so introduce extra code to handle this case. +! 2010-02-20 parrish - introduce modifications to allow dual resolution capability when running +! in hybrid ensemble mode. +! 2010-03-24 zhu - use cstate for generalizing control variable +! 2010-04-29 todling - update to use gsi_bundle; rename cstate to wbundle +! 2010-05-31 todling - better consistency checks; add co/co2 +! - ready to bypass analysis of (any) meteorological fields +! 2010-06-15 todling - generalized handling of chemistry +! 2011-02-22 zhu - add gust,vis,pblh +! 2011-05-15 auligne/todling - generalized cloud handling +! 2011-07-12 zhu - add do_cw_to_hydro_ad and cw2hydro_ad +! 2011-11-01 eliu - generalize the use of do_cw_to_hydro_ad +! 2012-02-08 kleist - remove strong_bk_ad and ensemble_forward_model_ad and related parameters +! 2013-05-23 zhu - add ntclen and predt for aircraft temperature bias correction +! 2013-10-25 todling - nullify work pointers +! 2013-10-28 todling - rename p3d to prse +! 2014-01-31 mkim - add support for when ql and qi are CVs for all-sky mw radiance DA +! 2014-03-19 pondeca - add wspd10m +! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl +! 2014-05-07 pondeca - add howv +! 2014-06-16 carley/zhu - add tcamt and lcbas +! 2014-12-03 derber - introduce parallel regions for optimization +! 2015-07-10 pondeca - add cloud ceiling height (cldch) +! 2016-05-03 pondeca - add uwnd10m, and vwnd10m +! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu +! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars. +! 2016-05-03 pondeca - add uwnd10m, and vwnd10m +! 2022-05-24 H.Wang - add amass2aero_ad for regional FV3-CMAQ DA when using +! total mass as control variable. +! +! input argument list: +! rval - State variable +! bval +! output argument list: +! grad - Control variable +! +!$$$ +use amassaeromod, only: amass2aero_ad +use cwhydromod, only: cw2hydro_ad +use cwhydromod, only: cw2hydro_ad_hwrf + +implicit none + +! Declare passed variables +type(gsi_bundle) , intent(inout) :: rval(nsubwin) +type(predictors) , intent(in ) :: bval +type(control_vector), intent(inout) :: grad + +! Declare local variables +character(len=*),parameter::myname='control2state_ad' +character(len=max_varname_length),allocatable,dimension(:) :: gases +character(len=max_varname_length),allocatable,dimension(:) :: clouds +integer(i_kind) :: ii,jj,ic,id,istatus,istatus_oz +type(gsi_bundle) :: wbundle ! work bundle + +real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() +real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() +!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() + +! Declare required local state variables +real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt=>NULL(),rv_lcbas=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL() + +real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter + + + +!****************************************************************************** + +if (c2sset_flg)call c2sset(grad,rval) +if (lsqrtb) then + write(6,*)trim(myname),': not for sqrt(B)' + call stop2(311) +end if + +! Inquire about clouds +if (nclouds>0) then + allocate(clouds(nclouds)) + call gsi_metguess_get ('clouds::3d',clouds,istatus) +endif + +! Inquire about chemistry +call gsi_chemguess_get('dim',ngases,istatus) +if (ngases>0) then + allocate(gases(ngases)) + call gsi_chemguess_get('gsinames',gases,istatus) +endif + + +! Loop over control steps +do jj=1,nsubwin + +! Create a work bundle similar to grad control vector's bundle + call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus ) + if (istatus/=0) then + write(6,*) trim(myname),': trouble creating work bundle' + call stop2(999) + endif + +!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter) + +!$omp section + + call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus) + call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus) + call gsi_bundlegetpointer (rval(jj),'u' ,rv_u, istatus) + call gsi_bundlegetpointer (rval(jj),'v' ,rv_v, istatus) + call gsi_bundleputvar ( wbundle, 'sf', zero, istatus ) + call gsi_bundleputvar ( wbundle, 'vp', zero, istatus ) +! Convert RHS calculations for u,v to st/vp for application of +! background error + if (do_getuv) then + if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then + call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus) + call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus) + allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), & + uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig)) + + uland=zero ; uwter=zero + vland=zero ; vwter=zero + + call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0) + + call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1) + call getuv(uland,vland,cv_sf,cv_vp,1) + deallocate(uland,vland,uwter,vwter) + else + call getuv(rv_u,rv_v,cv_sf,cv_vp,1) + endif + endif + + if(jj == 1)then + do ii=1,nsclen + grad%predr(ii)=bval%predr(ii) + enddo + do ii=1,npclen + grad%predp(ii)=bval%predp(ii) + enddo + if (ntclen>0) then + do ii=1,ntclen + grad%predt(ii)=bval%predt(ii) + enddo + end if + end if + +!$omp section + +! Get pointers to required control variables + call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus) + call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus) + call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus) + +! Get pointers to this subwin require state variables + call gsi_bundlegetpointer (rval(jj),'ps' ,rv_ps, istatus) + call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus) + call gsi_bundlegetpointer (rval(jj),'tv' ,rv_tv, istatus) + call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus) + call gsi_bundlegetpointer (rval(jj),'q' ,rv_q , istatus) + +! Adjoint of control to initial state + call gsi_bundleputvar ( wbundle, 't' , rv_tv, istatus ) + call gsi_bundleputvar ( wbundle, 'q' , zero, istatus ) + call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus ) + + if (do_cw_to_hydro .and. .not.do_cw_to_hydro_hwrf) then +! Case when cloud-vars do not map one-to-one +! e.g. cw-to-ql&qi + call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds) + elseif (do_cw_to_hydro_hwrf) then +! Case when cloud-vars do not map one-to-one +! e.g. cw-to-ql&qi&qr&qs&qg&qh + call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen) + else +! Case when cloud-vars map one-to-one, take care of them together +! e.g. cw-to-cw + do ic=1,nclouds + id=getindex(cvars3d,clouds(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus) + call gsi_bundleputvar (wbundle, clouds(ic),rv_rank3,istatus) + endif + enddo + end if +! Calculate sensible temperature + if(do_tv_to_tsen) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) + +! Adjoint of convert input normalized RH to q to add contribution of moisture +! to t, p , and normalized rh + if(do_normal_rh_to_q) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q) + +! Adjoint to convert ps to 3-d pressure + if(do_getprs) call getprs_ad(cv_ps,cv_t,rv_prse) + + +!$omp section + + call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus) + call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus ) + +! call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus) + call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus_oz) + + if (icoz>0) then + call gsi_bundleputvar ( wbundle, 'oz', rv_oz, istatus ) + else + if(istatus_oz==0) rv_oz=zero + end if + +! Same one-to-one map for chemistry-vars; take care of them together + if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then + write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!' + call stop2(999) + endif + + if (icvt_cmaq_fv3 == 2) then + call amass2aero_ad(rval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3) + else + do ic=1,ngases + id=getindex(cvars3d,gases(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus) + call gsi_bundleputvar (wbundle, gases(ic),rv_rank3,istatus) + endif + + id=getindex(cvars2d,gases(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus) + call gsi_bundleputvar (wbundle, gases(ic),rv_rank2,istatus) + endif + enddo + end if + if (icgust>0) then + call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus) + call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus ) + end if + if (icvis >0) then + call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus) + call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus ) + end if + if (icpblh>0)then + call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus) + call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus ) + end if + if (icwspd10m>0) then + call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus) + call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus ) + end if + if (ictd2m>0) then + call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus) + call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus ) + end if + if (icmxtm>0) then + call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus) + call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus ) + end if + if (icmitm>0) then + call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus) + call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus ) + end if + if (icpmsl>0) then + call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus) + call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus ) + end if + if (ichowv>0) then + call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus) + call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus ) + end if + if (icw>0) then + call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus) + call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus ) + if(nems_nmmb_regional)then + call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus) + call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus ) + end if + end if + if (ictcamt>0) then + call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus) + call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus ) + end if + if (iclcbas>0) then + call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus) + call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus) + call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus ) + ! Adjoint of convert loglcbas to lcbas + call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas) + end if + if (iccldch >0) then + call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus) + call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus ) + end if + if (icuwnd10m>0) then + call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus) + call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus ) + end if + if (icvwnd10m>0) then + call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus) + call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus ) + end if + +!$omp end parallel sections + +! Adjoint of transfer variables + + do ii=1,wbundle%ndim + grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii) + enddo + call gsi_bundledestroy(wbundle,istatus) + if (istatus/=0) then + write(6,*) trim(myname),': trouble destroying work bundle' + call stop2(999) + endif + +end do + +! Clean up +if (ngases>0) deallocate(gases) + +if (nclouds>0) deallocate(clouds) + +return +end subroutine control2state_ad +end module control2state_mod diff --git a/src/gsi/control2state_ad.f90 b/src/gsi/control2state_ad.f90 deleted file mode 100644 index ce1e9d2cd2..0000000000 --- a/src/gsi/control2state_ad.f90 +++ /dev/null @@ -1,441 +0,0 @@ -subroutine control2state_ad(rval,bval,grad) -!$$$ subprogram documentation block -! . . . . -! subprogram: control2state_ad -! prgmmr: tremolet -! -! abstract: Converts variables from physical space to control space -! This is also the adjoint of control2state -! -! program history log: -! 2007-04-16 tremolet - initial code -! 2008-11-28 todling - update to GSI May 2008: add tsen and p3d -! 2009-01-15 todling - handle predictors in quad precision -! 2009-04-21 derber - modify call to getstvp to call to getuv -! 2009-06-15 parrish - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run) -! 2009-08-12 lueken - update documentation -! 2009-11-27 parrish - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp -! so introduce extra code to handle this case. -! 2010-02-20 parrish - introduce modifications to allow dual resolution capability when running -! in hybrid ensemble mode. -! 2010-03-24 zhu - use cstate for generalizing control variable -! 2010-04-29 todling - update to use gsi_bundle; rename cstate to wbundle -! 2010-05-31 todling - better consistency checks; add co/co2 -! - ready to bypass analysis of (any) meteorological fields -! 2010-06-15 todling - generalized handling of chemistry -! 2011-02-22 zhu - add gust,vis,pblh -! 2011-05-15 auligne/todling - generalized cloud handling -! 2011-07-12 zhu - add do_cw_to_hydro_ad and cw2hydro_ad -! 2011-11-01 eliu - generalize the use of do_cw_to_hydro_ad -! 2012-02-08 kleist - remove strong_bk_ad and ensemble_forward_model_ad and related parameters -! 2013-05-23 zhu - add ntclen and predt for aircraft temperature bias correction -! 2013-10-25 todling - nullify work pointers -! 2013-10-28 todling - rename p3d to prse -! 2014-01-31 mkim - add support for when ql and qi are CVs for all-sky mw radiance DA -! 2014-03-19 pondeca - add wspd10m -! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl -! 2014-05-07 pondeca - add howv -! 2014-06-16 carley/zhu - add tcamt and lcbas -! 2014-12-03 derber - introduce parallel regions for optimization -! 2015-07-10 pondeca - add cloud ceiling height (cldch) -! 2016-05-03 pondeca - add uwnd10m, and vwnd10m -! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu -! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars. -! 2016-05-03 pondeca - add uwnd10m, and vwnd10m -! 2022-05-24 H.Wang - add amass2aero_ad for regional FV3-CMAQ DA when using -! total mass as control variable. -! -! input argument list: -! rval - State variable -! bval -! output argument list: -! grad - Control variable -! -!$$$ -use kinds, only: i_kind,r_kind -use control_vectors, only: control_vector -use control_vectors, only: cvars3d,cvars2d -use bias_predictors, only: predictors -use gsi_4dvar, only: nsubwin, lsqrtb -use gridmod, only: regional,lat2,lon2,nsig,twodvar_regional -use jfunc, only: nsclen,npclen,ntclen -use cwhydromod, only: cw2hydro_ad -use amassaeromod, only: amass2aero_ad -use cwhydromod, only: cw2hydro_ad_hwrf -use gsi_bundlemod, only: gsi_bundlecreate -use gsi_bundlemod, only: gsi_bundle -use gsi_bundlemod, only: gsi_bundlegetpointer -use gsi_bundlemod, only: gsi_bundlegetvar -use gsi_bundlemod, only: gsi_bundleputvar -use gsi_bundlemod, only: gsi_bundledestroy -use gsi_chemguess_mod, only: gsi_chemguess_get -use gsi_metguess_mod, only: gsi_metguess_get -use mpeu_util, only: getindex -use constants, only: max_varname_length,zero -use gridmod, only: nems_nmmb_regional -use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 - -implicit none - -! Declare passed variables -type(gsi_bundle) , intent(inout) :: rval(nsubwin) -type(predictors) , intent(in ) :: bval -type(control_vector), intent(inout) :: grad - -! Declare local variables -character(len=*),parameter::myname='control2state_ad' -character(len=max_varname_length),allocatable,dimension(:) :: gases -character(len=max_varname_length),allocatable,dimension(:) :: clouds -integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz -type(gsi_bundle) :: wbundle ! work bundle - -! Note: The following does not aim to get all variables in -! the state and control vectors, but rather the ones -! this routines knows how to handle. -integer(i_kind), parameter :: ncvars = 9 -integer(i_kind) :: icps(ncvars) -integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw -integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv -integer(i_kind) :: ictcamt,iclcbas,icsfwter,icvpwter -integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m -character(len=3), parameter :: mycvars(ncvars) = (/ & - 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) -logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi -real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() -real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() -!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() - -! Declare required local state variables -integer(i_kind), parameter :: nsvars = 12 -integer(i_kind) :: isps(nsvars) -character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & - 'qr ', 'qs ', 'qg ', 'qh ' /) -logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi -logical :: ls_qr,ls_qs,ls_qg,ls_qh -real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt=>NULL(),rv_lcbas=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL() - -real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter - -logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,do_cw_to_hydro_ad -logical :: do_cw_to_hydro_ad_hwrf - - -!****************************************************************************** - -if (lsqrtb) then - write(6,*)trim(myname),': not for sqrt(B)' - call stop2(311) -end if - -! Inquire about clouds -call gsi_metguess_get ('clouds::3d',nclouds,istatus) -if (nclouds>0) then - allocate(clouds(nclouds)) - call gsi_metguess_get ('clouds::3d',clouds,istatus) -endif - -! Inquire about chemistry -call gsi_chemguess_get('dim',ngases,istatus) -if (ngases>0) then - allocate(gases(ngases)) - call gsi_chemguess_get('gsinames',gases,istatus) -endif - -! Since each internal vector [step(jj)] of grad has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus) -lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 -lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 -lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 - -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (rval(1),mysvars,isps,istatus) -ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 -ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 -ls_qi =isps(7)>0; ls_w =isps(8)>0 -ls_qr =isps(9)>0; ls_qs =isps(10)>0 -ls_qg =isps(11)>0; ls_qh =isps(12)>0 - -! Define what to do depending on what's in CV and SV -do_getuv =lc_sf.and.lc_vp.and.ls_u .and.ls_v -do_tv_to_tsen_ad =lc_t .and.ls_q .and.ls_tsen -do_normal_rh_to_q_ad=lc_t .and.lc_rh.and.ls_prse.and.ls_q -do_getprs_ad =lc_t .and.lc_ps.and.ls_prse - -do_cw_to_hydro_ad=.false. -do_cw_to_hydro_ad_hwrf=.false. -if (regional) then - do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi - do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh -else - do_cw_to_hydro_ad=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global -endif - -call gsi_bundlegetpointer (grad%step(1),'oz',icoz,istatus) -call gsi_bundlegetpointer (grad%step(1),'gust',icgust,istatus) -call gsi_bundlegetpointer (grad%step(1),'vis',icvis,istatus) -call gsi_bundlegetpointer (grad%step(1),'pblh',icpblh,istatus) -call gsi_bundlegetpointer (grad%step(1),'wspd10m',icwspd10m,istatus) -call gsi_bundlegetpointer (grad%step(1),'td2m',ictd2m,istatus) -call gsi_bundlegetpointer (grad%step(1),'mxtm',icmxtm,istatus) -call gsi_bundlegetpointer (grad%step(1),'mitm',icmitm,istatus) -call gsi_bundlegetpointer (grad%step(1),'pmsl',icpmsl,istatus) -call gsi_bundlegetpointer (grad%step(1),'howv',ichowv,istatus) -call gsi_bundlegetpointer (grad%step(1),'sfwter',icsfwter,istatus) -call gsi_bundlegetpointer (grad%step(1),'vpwter',icvpwter,istatus) -call gsi_bundlegetpointer (grad%step(1),'w',icw,istatus) -call gsi_bundlegetpointer (grad%step(1),'tcamt',ictcamt,istatus) -call gsi_bundlegetpointer (grad%step(1),'lcbas',iclcbas,istatus) -call gsi_bundlegetpointer (grad%step(1),'cldch',iccldch,istatus) -call gsi_bundlegetpointer (grad%step(1),'uwnd10m',icuwnd10m,istatus) -call gsi_bundlegetpointer (grad%step(1),'vwnd10m',icvwnd10m,istatus) - -! Loop over control steps -do jj=1,nsubwin - -! Create a work bundle similar to grad control vector's bundle - call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus ) - if (istatus/=0) then - write(6,*) trim(myname),': trouble creating work bundle' - call stop2(999) - endif - -!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter) - -!$omp section - - call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus) - call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus) - call gsi_bundlegetpointer (rval(jj),'u' ,rv_u, istatus) - call gsi_bundlegetpointer (rval(jj),'v' ,rv_v, istatus) - call gsi_bundleputvar ( wbundle, 'sf', zero, istatus ) - call gsi_bundleputvar ( wbundle, 'vp', zero, istatus ) -! Convert RHS calculations for u,v to st/vp for application of -! background error - if (do_getuv) then - if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then - call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus) - call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus) - allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), & - uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig)) - - uland=zero ; uwter=zero - vland=zero ; vwter=zero - - call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0) - - call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1) - call getuv(uland,vland,cv_sf,cv_vp,1) - deallocate(uland,vland,uwter,vwter) - else - call getuv(rv_u,rv_v,cv_sf,cv_vp,1) - endif - endif - - if(jj == 1)then - do ii=1,nsclen - grad%predr(ii)=bval%predr(ii) - enddo - do ii=1,npclen - grad%predp(ii)=bval%predp(ii) - enddo - if (ntclen>0) then - do ii=1,ntclen - grad%predt(ii)=bval%predt(ii) - enddo - end if - end if - -!$omp section - -! Get pointers to required control variables - call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus) - call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus) - call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus) - -! Get pointers to this subwin require state variables - call gsi_bundlegetpointer (rval(jj),'ps' ,rv_ps, istatus) - call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus) - call gsi_bundlegetpointer (rval(jj),'tv' ,rv_tv, istatus) - call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus) - call gsi_bundlegetpointer (rval(jj),'q' ,rv_q , istatus) - -! Adjoint of control to initial state - call gsi_bundleputvar ( wbundle, 't' , rv_tv, istatus ) - call gsi_bundleputvar ( wbundle, 'q' , zero, istatus ) - call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus ) - - if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then -! Case when cloud-vars do not map one-to-one -! e.g. cw-to-ql&qi - call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds) - elseif (do_cw_to_hydro_ad_hwrf) then -! Case when cloud-vars do not map one-to-one -! e.g. cw-to-ql&qi&qr&qs&qg&qh - call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen) - else -! Case when cloud-vars map one-to-one, take care of them together -! e.g. cw-to-cw - do ic=1,nclouds - id=getindex(cvars3d,clouds(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus) - call gsi_bundleputvar (wbundle, clouds(ic),rv_rank3,istatus) - endif - enddo - end if -! Calculate sensible temperature - if(do_tv_to_tsen_ad) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) - -! Adjoint of convert input normalized RH to q to add contribution of moisture -! to t, p , and normalized rh - if(do_normal_rh_to_q_ad) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q) - -! Adjoint to convert ps to 3-d pressure - if(do_getprs_ad) call getprs_ad(cv_ps,cv_t,rv_prse) - - -!$omp section - - call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus) - call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus ) - -! call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus) - call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus_oz) - - if (icoz>0) then - call gsi_bundleputvar ( wbundle, 'oz', rv_oz, istatus ) - else - if(istatus_oz==0) rv_oz=zero - end if - -! Same one-to-one map for chemistry-vars; take care of them together - if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then - write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!' - call stop2(999) - endif - - if (icvt_cmaq_fv3 == 2) then - call amass2aero_ad(rval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3) - else - do ic=1,ngases - id=getindex(cvars3d,gases(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus) - call gsi_bundleputvar (wbundle, gases(ic),rv_rank3,istatus) - endif - - id=getindex(cvars2d,gases(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus) - call gsi_bundleputvar (wbundle, gases(ic),rv_rank2,istatus) - endif - enddo - end if - if (icgust>0) then - call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus) - call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus ) - end if - if (icvis >0) then - call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus) - call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus ) - end if - if (icpblh>0)then - call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus) - call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus ) - end if - if (icwspd10m>0) then - call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus) - call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus ) - end if - if (ictd2m>0) then - call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus) - call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus ) - end if - if (icmxtm>0) then - call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus) - call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus ) - end if - if (icmitm>0) then - call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus) - call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus ) - end if - if (icpmsl>0) then - call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus) - call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus ) - end if - if (ichowv>0) then - call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus) - call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus ) - end if - if (icw>0) then - call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus) - call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus ) - if(nems_nmmb_regional)then - call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus) - call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus ) - end if - end if - if (ictcamt>0) then - call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus) - call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus ) - end if - if (iclcbas>0) then - call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus) - call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus) - call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus ) - ! Adjoint of convert loglcbas to lcbas - call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas) - end if - if (iccldch >0) then - call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus) - call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus ) - end if - if (icuwnd10m>0) then - call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus) - call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus ) - end if - if (icvwnd10m>0) then - call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus) - call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus ) - end if - -!$omp end parallel sections - -! Adjoint of transfer variables - - do ii=1,wbundle%ndim - grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii) - enddo - call gsi_bundledestroy(wbundle,istatus) - if (istatus/=0) then - write(6,*) trim(myname),': trouble destroying work bundle' - call stop2(999) - endif - -end do - -! Clean up -if (ngases>0) deallocate(gases) - -if (nclouds>0) deallocate(clouds) - -return -end subroutine control2state_ad diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90 index 0847257777..97578124d2 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -83,6 +83,7 @@ module control_vectors use hybrid_ensemble_parameters, only: beta_s0,l_hyb_ens use hybrid_ensemble_parameters, only: grd_ens use constants, only : max_varname_length +use gridmod, only : minmype use m_rerank, only : rerank use GSI_BundleMod, only : GSI_BundleCreate @@ -112,7 +113,7 @@ module control_vectors public dot_product public prt_control_norms, axpy, random_cv, setup_control_vectors, & write_cv, read_cv, inquire_cv, maxval, qdot_prod_sub, init_anacv, & - final_anacv + final_anacv,c2sset_flg ! ! Public variables @@ -157,6 +158,7 @@ module control_vectors integer(i_kind) :: latlon11,latlon1n,lat2,lon2,nsig,n_ens integer(i_kind) :: nval_lenz_en logical,save :: lsqrtb,lcalc_gfdl_cfrac +logical :: c2sset_flg integer(i_kind) :: m_vec_alloc, max_vec_alloc, m_allocs, m_deallocs @@ -413,6 +415,7 @@ subroutine init_anacv write(6,*) myname_,': ALL CONTROL VARIABLES ', nrf_var end if lcalc_gfdl_cfrac = .false. +c2sset_flg = .true. end subroutine init_anacv subroutine final_anacv @@ -889,12 +892,12 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) end do endif else + m3d=xcv%step(1)%n3d + m2d=xcv%step(1)%n2d + itot=max(m3d,0)+max(m2d,0) + if(l_hyb_ens)itot=itot+n_ens*naensgrp + allocate(partsum(itot)) do ii=1,nsubwin - m3d=xcv%step(ii)%n3d - m2d=xcv%step(ii)%n2d - itot=max(m3d,0)+max(m2d,0) - if(l_hyb_ens)itot=itot+naensgrp*n_ens - allocate(partsum(itot)) !$omp parallel do schedule(dynamic,1) private(i) do i = 1,m3d partsum(i) = dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1) @@ -915,12 +918,12 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) do i=1,itot qdot_prod_sub = qdot_prod_sub + partsum(i) end do - deallocate(partsum) end do + deallocate(partsum) end if ! Duplicated part of vector - if(mype == 0)then + if(mype == minmype)then do j=nclen1+1,nclen qdot_prod_sub=qdot_prod_sub+xcv%values(j)*ycv%values(j) end do @@ -966,37 +969,35 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) character(len=*) , intent(in ) :: eb real(r_quad) , intent( out) :: prods(nsubwin+1) - real(r_quad) :: zz(nsubwin) integer(i_kind) :: ii,i,nn,m3d,m2d real(r_quad),allocatable,dimension(:) :: partsum integer(i_kind) :: ig integer(i_kind) ::ngtmp,nn0 prods(:)=zero_quad - zz(:)=zero_quad ! Independent part of vector if (lsqrtb) then if(trim(eb) == 'cost_b') then do ii=1,nsubwin - zz(ii)=zz(ii)+qdot_product( xcv%step(ii)%values(:) ,ycv%step(ii)%values(:) ) + prods(ii)=prods(ii)+qdot_product( xcv%step(ii)%values(:) ,ycv%step(ii)%values(:) ) end do endif if(trim(eb) == 'cost_e') then do ig=1,naensgrp do nn=1,n_ens do ii=1,nsubwin - zz(ii)=zz(ii)+qdot_product( xcv%aens(ii,ig,nn)%values(:) ,ycv%aens(ii,ig,nn)%values(:) ) + prods(ii)=prods(ii)+qdot_product( xcv%aens(ii,ig,nn)%values(:) ,ycv%aens(ii,ig,nn)%values(:) ) end do end do end do endif else if(trim(eb) == 'cost_b') then + m3d=xcv%step(1)%n3d + m2d=xcv%step(1)%n2d + allocate(partsum(m2d+m3d)) do ii=1,nsubwin - m3d=xcv%step(ii)%n3d - m2d=xcv%step(ii)%n2d - allocate(partsum(m2d+m3d)) !$omp parallel do schedule(dynamic,1) private(i) do i = 1,m3d partsum(i)= dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1) @@ -1006,17 +1007,17 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) partsum(m3d+i)= dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1) enddo do i = 1,m2d+m3d - zz(ii)=zz(ii) + partsum(i) + prods(ii)=prods(ii) + partsum(i) end do - deallocate(partsum) end do + deallocate(partsum) end if if(trim(eb) == 'cost_e') then - do ii=1,nsubwin ! RTod: somebody could work in opt/zing this ... - allocate(partsum(n_ens*naensgrp)) + allocate(partsum(n_ens*naensgrp)) + do ii=1,nsubwin +!$omp parallel do schedule(dynamic,1) private(nn,m3d,m2d,ig,ngtmp,nn0) do ig=1,naensgrp ngtmp=(ig-1)*n_ens -!$omp parallel do schedule(dynamic,1) private(nn,m3d,m2d) do nn=1,n_ens nn0=nn+ngtmp partsum(nn0) = zero_quad @@ -1031,20 +1032,17 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) enddo end do do nn=1,n_ens*naensgrp - zz(ii)=zz(ii)+partsum(nn) + prods(ii)=prods(ii)+partsum(nn) end do - deallocate(partsum) end do + deallocate(partsum) end if end if - call mpl_allreduce(nsubwin,qpvals=zz) - prods(1:nsubwin) = zz(1:nsubwin) - ! Duplicated part of vector - if(trim(eb) == 'cost_b') then + if(mype == minmype .and. trim(eb) == 'cost_b' ) then if (nsclen>0) then - prods(nsubwin+1) = prods(nsubwin+1) + qdot_product(xcv%predr(:),ycv%predr(:)) + prods(nsubwin+1) = qdot_product(xcv%predr(:),ycv%predr(:)) endif if (npclen>0) then prods(nsubwin+1) = prods(nsubwin+1) + qdot_product(xcv%predp(:),ycv%predp(:)) @@ -1054,6 +1052,9 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) endif end if + call mpl_allreduce(nsubwin+1,qpvals=prods) + + return end subroutine qdot_prod_vars_eb ! ---------------------------------------------------------------------- diff --git a/src/gsi/convthin.f90 b/src/gsi/convthin.f90 index cc6d2ed1b5..3a52188d73 100644 --- a/src/gsi/convthin.f90 +++ b/src/gsi/convthin.f90 @@ -326,11 +326,8 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then - iuse=.false. - ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases @@ -358,25 +355,17 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then - iuse=.false. - ! Case(4): none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then - iuse=.false. ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then + if (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then score_crit(itx,ip)= crit iobsout=ibest_obs(itx,ip) icount(itx,ip)=icount(itx,ip)+1 @@ -394,7 +383,8 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip) = iin ! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. else iuse = .false. end if @@ -473,8 +463,8 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp - real(r_kind) crit!,dist1 + real(r_kind) dx,dy,dp + real(r_kind) crit !,dist1 logical foreswp, aftswp @@ -510,13 +500,13 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -535,10 +525,10 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! TDR fore/aft (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps + iobs=iobs+1 + iobsout=iobs ! Case(1): first obs at this location, keep this obs as starting point if (icount_fore(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit_fore(itx,ip)= crit icount_fore(itx,ip)=icount_fore(itx,ip)+1 ibest_obs(itx,ip) = iobs @@ -549,8 +539,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters elseif (icount_fore(itx,ip) > 0 .and. crit < score_crit_fore(itx,ip)) then - iobs=iobs+1 - iobsout=iobs score_crit(itx,ip)= crit ! iobsout=ibest_obs(itx,ip) icount(itx,ip)=icount(itx,ip)+1 @@ -560,27 +548,19 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ibest_save(itx,ip)=iobs ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - iuse=.false. - ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else - iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind + iuse=.false. endif ! cases else if(aftswp) then ! aft sweeps + iobs=iobs+1 + iobsout=iobs ! Case(1): first obs at this location, keep this obs as starting point if (icount_aft(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit_aft(itx,ip)= crit icount_aft(itx,ip)=icount_aft(itx,ip)+1 ibest_obs(itx,ip) = iobs @@ -589,8 +569,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters elseif (icount_aft(itx,ip) > 0 .and. crit < score_crit_aft(itx,ip)) then - iobs=iobs+1 - iobsout=iobs score_crit_aft(itx,ip)= crit icount_aft(itx,ip)=icount_aft(itx,ip)+1 iobsout=ibest_obs(itx,ip) @@ -599,36 +577,20 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io rusage(iobs)=usage ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - ! Case(4): none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then - iobs=iobs+1 - iobsout=iobs + if (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then score_crit(itx,ip)= crit icount(itx,ip)=icount(itx,ip)+1 iiout = ibest_obs(itx,ip) @@ -640,20 +602,17 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit(itx,ip)= crit ibest_obs(itx,ip) = iobs icount(itx,ip)=icount(itx,ip)+1 ibest_save(itx,ip) = iin rusage(iobs)=usage -! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! or none of the above cases are satisified, +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if end if diff --git a/src/gsi/convthin_time.f90 b/src/gsi/convthin_time.f90 index 36ab178393..7f36caf09a 100644 --- a/src/gsi/convthin_time.f90 +++ b/src/gsi/convthin_time.f90 @@ -226,7 +226,8 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp + real(r_kind) dx,dy,dp +! real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -262,13 +263,13 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -306,10 +307,8 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& ibest_save_tm(itx,ip,itm)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit > score_crit_fore_tm(itx,ip,itm)) then - iuse=.false. ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases @@ -337,25 +336,17 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& ibest_save_tm(itx,ip,itm)=iin ! Case(3): obs score > best value at this location, +! Case(4): none of the above cases are satisified, ! --> do not use this obs, return to calling program. - elseif(icount_aft_tm(itx,ip,itm) > 0 .and. crit > score_crit_aft_tm(itx,ip,itm)) then - iuse=.false. - -! Case(4): none of the above cases are satisified, -! --> don't use this obs else iuse = .false. endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then - iuse=.false. ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then + if (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then score_crit_tm(itx,ip,itm)= crit iobsout=ibest_obs_tm(itx,ip,itm) icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 @@ -372,8 +363,9 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iin +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. end if @@ -447,7 +439,8 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp + real(r_kind) dx,dy,dp +! real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -484,13 +477,13 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -508,19 +501,11 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! TDR fore (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_fore_tm(itx,ip,itm) .and. icount_fore_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + iobs=iobs+1 + iobsout=iobs + if (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then score_crit_fore_tm(itx,ip,itm)= crit ! iobsout=ibest_obs_tm(itx,ip) icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1 @@ -532,8 +517,6 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_fore_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_fore_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs @@ -541,28 +524,20 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ibest_save_tm(itx,ip,itm) = iobs ! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if ! TDR aft (Pseudo-dual-Doppler-radars) else if(aftswp) then ! fore sweeps -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_aft_tm(itx,ip,itm) .and. icount_aft_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + if (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then score_crit_aft_tm(itx,ip,itm)= crit ! iobsout=ibest_obs_tm(itx,ip) icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 @@ -574,37 +549,27 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_aft_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_aft_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iobs +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind end if else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + if (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then score_crit_tm(itx,ip,itm)= crit icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 iiout = ibest_obs_tm(itx,ip,itm) @@ -616,20 +581,17 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iin +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if end if diff --git a/src/gsi/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90 index 683e13d742..7a14cd3226 100644 --- a/src/gsi/correlated_obsmod.F90 +++ b/src/gsi/correlated_obsmod.F90 @@ -977,11 +977,15 @@ subroutine upd_varch_ if(isurf==1) then if(iamroot_)write(6,'(1x,a6,a20,2i6,2f20.15)')'>>>',idnames(itbl),jj,nn,varch(mm),sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - endif - if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==2) then + varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==3) then + varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==4) then + varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==5) then + varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + end if enddo else allocate(ircv(nchanl1)) @@ -1023,15 +1027,9 @@ subroutine upd_varch_ IJsubset(iii)=ijac(ii) ! subset indexes in channels presently in use endif enddo - if (iii/=ncp) then - if (iamroot_) then - write(6,*) myname, ' iii,ncp= ',iii,ncp - endif - call die(myname_,' serious dimensions insconsistency, aborting') - endif - if (jjj/=ncp) then + if (iii/=ncp .or. jjj/=ncp) then if (iamroot_) then - write(6,*) myname, ' jjj,ncp= ',jjj,ncp + write(6,*) myname, ' iii,jjj,ncp= ',iii,jjj,ncp endif call die(myname_,' serious dimensions insconsistency, aborting') endif @@ -1039,11 +1037,17 @@ subroutine upd_varch_ nn=IJsubset(ii) mm=ich1(nn) rr=IRsubset(ii) - if(isurf==1) varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + if(isurf==1) then + varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==2) then + varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==3) then + varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==4) then + varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==5) then + varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + end if enddo ! clean up deallocate(IJsubset) @@ -1260,18 +1264,12 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga IJsubset(iii)=ijac(ii) ! subset indexes in Jac/dep presently in use endif enddo - if (iii/=ncp) then + if (iii/=ncp .and. jjj/=ncp) then if (iamroot_) then - write(6,*) myname, ' iii,ncp= ',iii,ncp + write(6,*) myname, ' iii,ncp= ',iii,jjj,ncp endif call die(myname_,' serious dimensions insconsistency (R), aborting') endif - if (jjj/=ncp) then - if (iamroot_) then - write(6,*) myname, ' jjj,ncp= ',jjj,ncp - endif - call die(myname_,' serious dimensions insconsistency (J), aborting') - endif if( ErrorCov%method<0 ) then ! Keep departures and Jacobian unchanged @@ -1300,33 +1298,25 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga ! decompose the sub-matrix - returning the result in the ! structure holding the full covariance - nsigjac=size(jacobian,1) - allocate(row(nsigjac,ncp)) - allocate(col(ncp),col2(ncp)) - row=zero_quad - col=zero_quad - col2=zero_quad - - allocate(qcaj(ncp)) allocate(UT(ncp,ncp)) - qcaj = one - UT = zero if( ErrorCov%method==2 ) then if(lqcoef)then + allocate(qcaj(ncp)) do jj=1,ncp - jjj=IJsubset(jj) - qcaj(jj) = raterr2(jjj) + qcaj(jj) = raterr2(IJsubset(jj)) enddo subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd,qcaj) + deallocate(qcaj) else subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd) endif else if( ErrorCov%method==1 ) then + allocate(qcaj(ncp)) do jj=1,ncp - jjj=IJsubset(jj) - qcaj(jj) = varinv(jjj) + qcaj(jj) = varinv(IJsubset(jj)) enddo subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd,qcaj) + deallocate(qcaj) endif if(.not.subset) then @@ -1345,23 +1335,31 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga do kk=ii,ncp rinvdiag(ii)=rinvdiag(ii)+UT(ii,kk)**2 enddo - enddo + end do + nsigjac=size(jacobian,1) + allocate(row(nsigjac,ncp)) + allocate(col(ncp),col2(ncp)) +!$omp parallel do schedule(dynamic,1) private(ii,jj,nn) do ii=1,ncp + row(:,ii)=zero_quad + col(ii)=zero_quad + col2(ii)=zero_quad do jj=1,ii nn=IJsubset(jj) col(ii) = col(ii) + UT(jj,ii) * depart(nn) - col2(ii) = col2(ii) + UT(jj,ii) * obs(nn) + col2(ii) = col2(ii) + UT(jj,ii) * obs(nn) row(:,ii) = row(:,ii) + UT(jj,ii) * jacobian(:,nn) enddo enddo + deallocate(UT) ! Place Jacobian and departure in output arrays - do jj=1,ncp - mm=IJsubset(jj) - depart(mm)=col(jj) - obs(mm)=col2(jj) - jacobian(:,mm)=row(:,jj) + do ii=1,ncp + mm=IJsubset(ii) + depart(mm)=col(ii) + obs(mm)=col2(ii) + jacobian(:,mm)=row(:,ii) raterr2(mm) = one err2(mm) = one wgtjo(mm) = one @@ -1369,8 +1367,6 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga deallocate(col,col2) deallocate(row) - deallocate(qcaj) - deallocate(UT) else if( ErrorCov%method==3 ) then !use diag(Re) scales GSI specified errors ! inv(Rg) = inv(De*Dg) @@ -1445,17 +1441,16 @@ logical function choleskydecom_inv_(Isubset,IJsubset,ErrorCov,UT,diagadd,qcaj) do ii=1,ncp UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj))/sqrt(qcaj(ii)*qcaj(jj)) enddo + UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) enddo else do jj=1,ncp do ii=1,ncp UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj)) enddo + UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) enddo endif - do jj=1,ncp - UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) - enddo if(r_kind==r_single) then ! this trick only works because this uses the f77 lapack interfaces call SPOTRF('U', ncp, UT, ncp, info ) else if(r_kind==r_double) then diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 6e94b29c6c..5a3e72970d 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -52,7 +52,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) use constants, only: zero,one,half,zero_single,rd_over_cp,one_tenth use mpimod, only: mpi_comm_world,ierror,mype,npe use hybrid_ensemble_parameters, only: n_ens,grd_ens,parallelization_over_ensmembers - use hybrid_ensemble_parameters, only: l_both_fv3sar_gfs_ens, n_ens_gfs,n_ens_fv3sar + use hybrid_ensemble_parameters, only: l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_fv3sar use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use gsi_bundlemod, only: gsi_bundlecreate @@ -674,7 +674,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) ! ! ! CONVERT ENSEMBLE MEMBERS TO ENSEMBLE PERTURBATIONS - sig_norm=sqrt(one/max(one,n_ens_fv3sar-one)) + sig_norm=sqrt(weight_ens_fv3sar/max(one,n_ens_fv3sar-one)) do n=imem_start,n_ens do i=1,nelen @@ -1021,7 +1021,7 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var use kinds, only: r_kind,r_single,i_kind - use gridmod, only: eta1_ll,eta2_ll + use gridmod, only: eta1_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 @@ -1036,14 +1036,11 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv_v1 use gsi_rfv3io_mod, only: gsi_fv3ncdf2d_read_v1 - use directDA_radaruse_mod, only: l_use_dbz_directDA use gsi_bundlemod, only: gsi_gridcreate use gsi_bundlemod, only: gsi_grid use gsi_bundlemod, only: gsi_bundlecreate,gsi_bundledestroy use gsi_bundlemod, only: gsi_bundlegetvar use obsmod, only: if_model_dbz - use directDA_radaruse_mod, only: l_use_cvpqx, cvpqx_pval, cld_nt_updt - use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval use gsi_rfv3io_mod, only: gsi_fv3ncdf_read_ens_parallel_over_ens,gsi_fv3ncdf_readuv_ens_parallel_over_ens @@ -1085,7 +1082,6 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin character(len=:),allocatable :: tracers !='fv3_tracer' character(len=:),allocatable :: sfcdata !='fv3_sfcdata' character(len=:),allocatable :: couplerres!='coupler.res' - integer (i_kind) ier,istatus associate( this => this ) ! eliminates warning for unused dummy argument needed for binding @@ -1205,7 +1201,7 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & use hybrid_ensemble_parameters, only: grd_ens use mpimod, only: mpi_comm_world,ierror,mpi_rtype use kinds, only: r_kind,r_single,i_kind - use gridmod,only: itotsub + use constants, only: half,zero implicit none @@ -1234,6 +1230,7 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & ! transfer data from root to subdomains on each task ! scatterv used, since full grids exist only on root task. allocate(wrk_send_2d(grd_ens%itotsub)) + g_oz=zero ! first PS (output from fill_regional_2d is a column vector with a halo) if(mype==iope) call this%fill_regional_2d(gg_ps,wrk_send_2d) call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & diff --git a/src/gsi/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index c16c0e8c0e..550f85d209 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -16,12 +16,22 @@ module get_gfs_ensmod_mod ! machine: ibm RS/6000 SP ! !$$$ + use kinds, only: i_kind,r_kind,r_single use mpeu_util, only: die use mpimod, only: mype,npe use abstract_ensmod, only: this_ens_class => abstractEnsemble + use genex_mod, only: genex_info implicit none private + + integer(i_kind) :: ias,iae,iasm,iaem,iaemz,jas,jae,jasm,jaem,jaemz + integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz + integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz + integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz + integer(i_kind) :: n2d + type(genex_info) :: s_a2b + public :: ensemble public :: ensemble_typemold @@ -84,7 +94,6 @@ subroutine get_gfs_Nens(this,grd,members,ntindex,atm_bundle,iret) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use gridmod, only: use_gfs_nemsio, use_gfs_ncio use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: ens_fast_read @@ -153,10 +162,10 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & ! ! input argument list: ! ntindex - time index for ensemble -! ens_atm_bundle - atm bundle w/ fields for ensemble +! atm_bundle - atm bundle w/ fields for ensemble ! ! output argument list: -! ens_atm_bundle - atm bundle w/ fields for ensemble +! atm_bundle - atm bundle w/ fields for ensemble ! iret - return code, 0 for successful read. ! ! attributes: @@ -166,16 +175,16 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & !$$$ use mpimod, only: mpi_comm_world,ierror,mpi_real8,mpi_integer4,mpi_max - use kinds, only: i_kind,r_single,r_kind use constants, only: zero use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_destroy_info use gsi_4dvar, only: ens_fhrlevs use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only : assignment(=) use hybrid_ensemble_parameters, only: n_ens,grd_ens use hybrid_ensemble_parameters, only: ensemble_path use control_vectors, only: nc2d,nc3d !use control_vectors, only: cvars2d,cvars3d - use genex_mod, only: genex_info,genex_create_info,genex,genex_destroy_info + use genex_mod, only: genex_create_info,genex,genex_destroy_info use gridmod, only: use_gfs_nemsio use jfunc, only: cnvw_option @@ -193,18 +202,13 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & character(len=*),parameter :: myname_='get_user_ens_gfs_fastread_' character(len=70) :: filename character(len=70) :: filenamesfc - integer(i_kind) :: i,ii,j,jj,k,n + integer(i_kind) :: i,ii,j,k,n integer(i_kind) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens - integer(i_kind) :: ip,ips,ipe,jps,jpe - integer(i_kind) :: ias,iae,iasm,iaem,iaemz,jas,jae,jasm,jaem,jaemz - integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz - integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz - integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz - integer(i_kind) :: n2d + integer(i_kind) :: ip integer(i_kind) :: nlon,nlat,nsig - type(genex_info) :: s_a2b + integer(i_kind),dimension(n_ens) :: io_pe0 real(r_single),allocatable,dimension(:,:,:,:) :: en_full,en_loc - real(r_kind),allocatable,dimension(:,:,:) :: en_loc3 + real(r_kind),allocatable,dimension(:) :: sloc integer(i_kind),allocatable,dimension(:) :: m_cvars2dw,m_cvars3dw integer(i_kind) :: m_cvars2d(nc2d),m_cvars3d(nc3d) type(sub2grid_info) :: grd3d @@ -214,61 +218,69 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & nlon=grd_ens%nlon nsig=grd_ens%nsig + if(ntindex == 1)then ! set up partition of available processors for parallel read - if ( n_ens > npe ) & - call die(myname_, ': ***ERROR*** CANNOT READ ENSEMBLE n_ens > npe, increase npe >= n_ens', 99) + if ( n_ens > npe ) & + call die(myname_, ': ***ERROR*** CANNOT READ ENSEMBLE n_ens > npe, increase npe >= n_ens', 99) - call ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens) - ! setup communicator for scatter to subdomains: - - ! first, define gsi subdomain boundaries in global units: + call ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens) - ip=1 ! halo width is hardwired at 1 - ips=grd_ens%istart(mype+1) - ipe=ips+grd_ens%lat1-1 - jps=grd_ens%jstart(mype+1) - jpe=jps+grd_ens%lon1-1 + ! setup communicator for scatter to subdomains: + ! first, define gsi subdomain boundaries in global units: !!!!!!!!!!!!NOTE--FOLLOWING HAS MANY VARS TO BE DEFINED--NLAT,NLON ARE ENSEMBLE DOMAIN DIMS !!!!!!!!for example, n2d = nc3d*nsig + nc2d - n2d=nc3d*grd_ens%nsig+nc2d - ias=1 ; iae=0 ; jas=1 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0 - if(mype==io_pe) then - iae=nlat - jae=nlon - kae=n2d - mas=n_io_pe_s ; mae=n_io_pe_em - endif - iasm=ias ; iaem=iae ; jasm=jas ; jaem=jae ; kasm=kas ; kaem=kae ; masm=mas ; maem=mae - - ibs =ips ; ibe =ipe ; jbs =jps ; jbe =jpe - ibsm=ibs-ip ; ibem=ibe+ip ; jbsm=jbs-ip ; jbem=jbe+ip - kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens - kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe - iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem) - kaemz=max(kasm,kaem) ; maemz=max(masm,maem) - ibemz=max(ibsm,ibem) ; jbemz=max(jbsm,jbem) - kbemz=max(kbsm,kbem) ; mbemz=max(mbsm,mbem) - call genex_create_info(s_a2b,ias ,iae ,jas ,jae ,kas ,kae ,mas ,mae , & - ibs ,ibe ,jbs ,jbe ,kbs ,kbe ,mbs ,mbe , & - iasm,iaem,jasm,jaem,kasm,kaem,masm,maem, & - ibsm,ibem,jbsm,jbem,kbsm,kbem,mbsm,mbem) - - write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas -22 format(a,'sigf',i2.2,'_ens_mem',i3.3) + n2d=nc3d*grd_ens%nsig+nc2d + ias=1 ; iae=0 ; jas=1 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0 + if(mype==io_pe) then + iae=nlat + jae=nlon + kae=n2d + mas=n_io_pe_s ; mae=n_io_pe_em + endif + iasm=ias ; iaem=iae ; jasm=jas ; jaem=jae ; kasm=kas ; kaem=kae ; masm=mas ; maem=mae + + ip=1 ! halo width is hardwired at 1 + ibs=grd_ens%istart(mype+1) + ibe=ibs+grd_ens%lat1-1 + jbs=grd_ens%jstart(mype+1) + jbe=jbs+grd_ens%lon1-1 + + ibsm=ibs-ip ; ibem=ibe+ip ; jbsm=jbs-ip ; jbem=jbe+ip + kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens + kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe + iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem) + kaemz=max(kasm,kaem) ; maemz=max(masm,maem) + ibemz=max(ibsm,ibem) ; jbemz=max(jbsm,jbem) + kbemz=max(kbsm,kbem) ; mbemz=max(mbsm,mbem) + call genex_create_info(s_a2b,ias ,iae ,jas ,jae ,kas ,kae ,mas ,mae , & + ibs ,ibe ,jbs ,jbe ,kbs ,kbe ,mbs ,mbe , & + iasm,iaem,jasm,jaem,kasm,kaem,masm,maem, & + ibsm,ibem,jbsm,jbem,kbsm,kbem,mbsm,mbem) + + if(mype==0)then + do n=1,n_ens + write(6,'(3(a,1x,i5,1x))') 'reading ensemble member', n,'on pe', io_pe0(n) + enddo + end if + end if + if(mype==0) write(6,*) ' reading time level ',ntindex allocate(m_cvars2dw(nc2din),m_cvars3dw(nc3din)) m_cvars2dw=-999 m_cvars3dw=-999 - allocate(en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz)) + !! read ensembles if ( mas == mae ) then + allocate(en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz)) + write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas +22 format(a,'sigf',i2.2,'_ens_mem',i3.3) if ( use_gfs_nemsio ) then if (cnvw_option) then write(filenamesfc,23) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas @@ -284,54 +296,54 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & filename,.true.) end if else - call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & + call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & ias,jas,mas, & iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename) end if + else + allocate(en_full(1,1,1,1)) end if call mpi_allreduce(m_cvars2dw,m_cvars2d,nc2d,mpi_integer4,mpi_max,mpi_comm_world,ierror) call mpi_allreduce(m_cvars3dw,m_cvars3d,nc3d,mpi_integer4,mpi_max,mpi_comm_world,ierror) deallocate(m_cvars2dw,m_cvars3dw) + ! scatter to subdomains: +! en_loc=zero allocate(en_loc(ibsm:ibemz,jbsm:jbemz,kbsm:kbemz,mbsm:mbemz)) - - en_loc=zero call genex(s_a2b,en_full,en_loc) deallocate(en_full) - call genex_destroy_info(s_a2b) ! check on actual routine name -! transfer en_loc to en_loc3 then to atm_bundle - allocate(en_loc3(lat2in,lon2in,nc2d+nc3d*nsig)) +! call genex_destroy_info(s_a2b) ! check on actual routine name + - iret = 0 + allocate(sloc(lat2in*lon2in*(nc2d+nc3d*nsig))) call create_grd23d_(grd3d,nc2d+nc3d*grd%nsig) + + iret=0 do n=1,n_ens + ii=0 do k=1,nc2d+nc3d*nsig - jj=0 do j=jbsm,jbem - jj=jj+1 - ii=0 do i=ibsm,ibem ii=ii+1 - en_loc3(ii,jj,k)=en_loc(i,j,k,n) + sloc(ii)=en_loc(i,j,k,n) enddo enddo enddo - call move2bundle_(grd3d,en_loc3,atm_bundle(n),m_cvars2d,m_cvars3d,iret) + call move2bundle_(grd3d,sloc,atm_bundle(n),m_cvars2d,m_cvars3d,iret) enddo + deallocate(en_loc,sloc) call general_sub2grid_destroy_info(grd3d,grd) - deallocate(en_loc,en_loc3) - end subroutine get_user_ens_gfs_fastread_ -subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) +subroutine move2bundle_(grd3d,sloc,atm_bundle,m_cvars2d,m_cvars3d,iret) !$$$ subprogram documentation block ! . . . . @@ -347,7 +359,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! ! input argument list: ! grd - grd info for ensemble -! en_loc3 - ensemble member +! sloc - ensemble member ! atm_bundle - empty atm bundle ! m_cvars2d - maps 3rd index in en_loc3 for start of each 2d variable ! m_cvars3d - maps 3rd index in en_loc3 for start of each 3d variable @@ -361,13 +373,11 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero,one,two,fv use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: en_perts use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_bundlemod, only : assignment(=) use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use mpeu_util, only: getindex @@ -375,27 +385,28 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! Declare passed variables type(sub2grid_info), intent(in ) :: grd3d - real(r_kind), intent(inout) :: en_loc3(grd3d%lat2,grd3d%lon2,nc2d+nc3d*grd3d%nsig) type(gsi_bundle), intent(inout) :: atm_bundle + real(r_kind), intent(inout) :: sloc(grd3d%lat2*grd3d%lon2*(nc2d+nc3d*grd3d%nsig)) integer(i_kind), intent(in ) :: m_cvars2d(nc2d),m_cvars3d(nc3d) - integer(i_kind), intent( out) :: iret + integer(i_kind), intent(inout) :: iret ! Declare internal variables character(len=*),parameter :: myname_='move2bundle_' character(len=70) :: filename integer(i_kind) :: ierr - integer(i_kind) :: km,m + integer(i_kind) :: km1,m integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg real(r_kind),pointer,dimension(:,:) :: ps !real(r_kind),pointer,dimension(:,:) :: sst + real(r_kind),dimension(grd3d%lat2,grd3d%lon2,nc2d+nc3d*grd3d%nsig)::en_loc3 real(r_kind),pointer,dimension(:,:,:) :: u,v,tv,q,oz,cwmr real(r_kind),pointer,dimension(:,:,:) :: qlmr,qimr,qrmr,qsmr,qgmr real(r_kind),parameter :: r0_001 = 0.001_r_kind !--- now update halo values of all variables using general_sub2grid - call update_halos_(grd3d,en_loc3) + call update_halos_(grd3d,sloc,en_loc3) ! Check hydrometeors in control variables icw=getindex(cvars3d,'cw') @@ -405,12 +416,16 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) iqs=getindex(cvars3d,'qs') iqg=getindex(cvars3d,'qg') -! initialize atm_bundle to zero +! atm_bundle to zero done earlier - atm_bundle=zero + call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = iret+ierr + !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = iret+ierr + do m=1,nc2d +! convert ps from Pa to cb + if(trim(cvars2d(m))=='ps') ps=r0_001*en_loc3(:,:,m_cvars2d(m)) +! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now + enddo - call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = ierr - !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = ierr call gsi_bundlegetpointer(atm_bundle,'sf',u , ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'vp',v , ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'t' ,tv, ierr); iret = ierr + iret @@ -425,7 +440,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) if ( iret /= 0 ) then if ( mype == 0 ) then write(6,'(A)') trim(myname_) // ': ERROR!' - write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz,cw' + write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz' write(6,'(A)') trim(myname_) // ': but some have not been found. Aborting ... ' write(6,'(A)') trim(myname_) // ': WARNING!' write(6,'(3A,I5)') trim(myname_) // ': Trouble reading ensemble file : ', trim(filename), ', IRET = ', iret @@ -433,38 +448,31 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) return endif - - do m=1,nc2d -! convert ps from Pa to cb - if(trim(cvars2d(m))=='ps') ps=r0_001*en_loc3(:,:,m_cvars2d(m)) -! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now - enddo - - km = en_perts(1,1,1)%grid%km + km1 = en_perts(1,1,1)%grid%km - 1 !$omp parallel do schedule(dynamic,1) private(m) do m=1,nc3d if(trim(cvars3d(m))=='sf')then - u = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + u = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='vp') then - v = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + v = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='t') then - tv = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + tv = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='q') then - q = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + q = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='oz') then - oz = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + oz = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='cw') then - cwmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + cwmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='ql') then - qlmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qlmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='qi') then - qimr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qimr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='qr') then - qrmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qrmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='qs') then - qsmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qsmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='qg') then - qgmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qgmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) end if enddo @@ -477,7 +485,6 @@ end subroutine move2bundle_ subroutine create_grd23d_(grd23d,nvert) - use kinds, only: i_kind use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info use hybrid_ensemble_parameters, only: grd_ens @@ -498,21 +505,20 @@ subroutine create_grd23d_(grd23d,nvert) end subroutine create_grd23d_ -subroutine update_halos_(grd,s) +subroutine update_halos_(grd,sloc,s) - use kinds, only: i_kind,r_kind use general_sub2grid_mod, only: sub2grid_info,general_sub2grid,general_grid2sub implicit none ! Declare passed variables type(sub2grid_info), intent(in ) :: grd - real(r_kind), intent(inout) :: s(grd%lat2,grd%lon2,grd%num_fields) + real(r_kind), intent( out) :: s(grd%lat2,grd%lon2,grd%num_fields) + real(r_kind), intent(inout) :: sloc(grd%lat2*grd%lon2*grd%num_fields) ! Declare local variables - integer(i_kind) inner_vars,lat2,lon2,nlat,nlon,nvert,kbegin_loc,kend_loc,kend_alloc + integer(i_kind) inner_vars,lat2,lon2,nlat,nlon,nvert,kbegin_loc,kend_alloc integer(i_kind) ii,i,j,k - real(r_kind),allocatable,dimension(:) :: sloc real(r_kind),allocatable,dimension(:,:,:,:) :: work lat2=grd%lat2 @@ -522,22 +528,16 @@ subroutine update_halos_(grd,s) nvert=grd%num_fields inner_vars=grd%inner_vars kbegin_loc=grd%kbegin_loc - kend_loc=grd%kend_loc kend_alloc=grd%kend_alloc - allocate(sloc(lat2*lon2*nvert)) + + + allocate(work(inner_vars,nlat,nlon,kbegin_loc:kend_alloc)) - ii=0 - do k=1,nvert - do j=1,lon2 - do i=1,lat2 - ii=ii+1 - sloc(ii)=s(i,j,k) - enddo - enddo - enddo call general_sub2grid(grd,sloc,work) call general_grid2sub(grd,work,sloc) + deallocate(work) + ii=0 do k=1,nvert do j=1,lon2 @@ -548,33 +548,30 @@ subroutine update_halos_(grd,s) enddo enddo - deallocate(sloc,work) - end subroutine update_halos_ -subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens) +subroutine ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens) ! do computation on all processors, then assign final local processor ! values. - use kinds, only: r_kind,i_kind use constants, only: half implicit none ! Declare passed variables - integer(i_kind),intent(in ) :: n_ens,ntindex + integer(i_kind),intent(in ) :: n_ens integer(i_kind),intent( out) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens + integer(i_kind),intent( out) :: io_pe0(n_ens) ! Declare local variables - integer(i_kind) :: io_pe0(n_ens) integer(i_kind) :: iskip,jskip,nextra,ipe,n integer(i_kind) :: nsig i_ens=-1 nsig=1 iskip=npe/n_ens - nextra=npe-iskip*n_ens + nextra=npe-iskip*(n_ens-1)-1 jskip=iskip io_pe=-1 io_pe0=-1 @@ -589,13 +586,12 @@ subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em, else jskip=iskip endif + if(ipe > npe) then + write(6,*)' ens_io_partition_: ***ERROR*** ',ipe,jskip,' processor error: PROGRAM STOPS' + call stop2(999) + end if ipe=ipe+jskip enddo - if(mype==0)then - do n=1,n_ens - write(6,'(3(a,1x,i5,1x))') 'reading ensemble member', n,' time level',ntindex,'on pe', io_pe0(n) - enddo - end if do n=1,n_ens if(mype==io_pe0(n)) then @@ -614,7 +610,6 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename,init_head,filenamesfc) - use kinds, only: i_kind,r_kind,r_single use constants, only: r60,r3600,zero,one,half,deg2rad use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close use ncepnems_io, only: error_msg,imp_physics @@ -641,7 +636,6 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi ! Declare local variables integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,latb2,lonb2 integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf - integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg integer(i_kind) iret integer(i_kind) :: istop = 101 integer(i_kind),dimension(7):: idate @@ -726,23 +720,40 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi allocate(work(nlon*(nlat-2))) if (imp_physics == 11) allocate(work2(nlon*(nlat-2))) allocate(temp3(nlat,nlon,nsig,nc3d)) - allocate(temp2(nlat,nlon,nc2d)) + temp3=zero k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0 - k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0 do k3=1,nc3d - if(cvars3d(k3)=='sf') k3u=k3 - if(cvars3d(k3)=='vp') k3v=k3 - if(cvars3d(k3)=='t') k3t=k3 - if(cvars3d(k3)=='q') k3q=k3 - if(cvars3d(k3)=='cw') k3cw=k3 - if(cvars3d(k3)=='oz') k3oz=k3 - if(cvars3d(k3)=='ql') k3ql=k3 - if(cvars3d(k3)=='qi') k3qi=k3 - if(cvars3d(k3)=='qr') k3qr=k3 - if(cvars3d(k3)=='qs') k3qs=k3 - if(cvars3d(k3)=='qg') k3qg=k3 do k=1,nsig - if(trim(cvars3d(k3))=='cw') then + if(trim(cvars3d(k3))=='t') then + k3t=k3 + call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='sf') then + k3u=k3 + call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='vp') then + k3v=k3 + call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='q') then + k3q=k3 + call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='oz') then + k3oz=k3 + call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='cw') then + k3cw=k3 call nemsio_readrecv(gfile,'clwmr','mid layer',k,work,iret=iret) if (iret /= 0) call error_msg(trim(myname_),trim(filename),'clwmr','read',istop+6,iret,.true.) if (imp_physics == 11) then @@ -789,30 +800,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi if (iret /= 0) call error_msg(trim(myname_),trim(filename),'grle','read',istop+12,iret) call move1_(work,temp3(:,:,k,k3),nlon,nlat) call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='oz') then - call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='q') then - call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='t') then - call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='sf') then - call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='vp') then - call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - endif + end if enddo enddo do k=1,nsig @@ -822,10 +810,29 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) & write(6,'(" WARNING, problem with one of k3-")') +! move temp3 to en_full + kf=0 + do k3=1,nc3d + m_cvars3d(k3)=kf+1 + do k=1,nsig + kf=kf+1 + jj=jas-1 + do j=1,nlon + jj=jj+1 + ii=ias-1 + do i=1,nlat + ii=ii+1 + en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) + enddo + enddo + enddo + enddo + deallocate(temp3) ! convert T to Tv: postpone this calculation ! temp3(:,:,:,k3t)=temp3(:,:,:,k3t)*(one+fv*temp3(:,:,:,k3q)) + allocate(temp2(nlat,nlon,nc2d)) temp2=zero do k2=1,nc2d !if(trim(cvars2d(k2))=='sst') then @@ -844,24 +851,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi deallocate(work) if (imp_physics == 11) deallocate(work2) -! move temp2,temp3 to en_full - kf=0 - do k3=1,nc3d - m_cvars3d(k3)=kf+1 - do k=1,nsig - kf=kf+1 - jj=jas-1 - do j=1,nlon - jj=jj+1 - ii=ias-1 - do i=1,nlat - ii=ii+1 - en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) - enddo - enddo - enddo - enddo - deallocate(temp3) +! move temp2 to en_full do k2=1,nc2d m_cvars2d(k2)=kf+1 kf=kf+1 @@ -894,7 +884,6 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: r60,r3600,zero,one,half,deg2rad use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use general_sub2grid_mod, only: sub2grid_info @@ -917,7 +906,6 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig logical :: file_exist integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,kr,ierror integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf - integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg character(len=120) :: myname_ = 'parallel_read_gfsnc_state_' real(r_single),allocatable,dimension(:,:,:) :: rwork3d1, rwork3d2 real(r_single),allocatable,dimension(:,:) :: temp2,rwork2d @@ -935,12 +923,12 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig call die(myname_, ': ***FATAL ERROR*** insufficient ens fcst for hybrid',999) endif + ierror=0 ! If file exists, open and process atmges = open_dataset(filename,errcode=ierror) if (ierror /=0) then - write(6,*)' PARALLEL_READ_GFSNC_STATE: ***FATAL ERROR*** problem reading ',& - trim(filename),' ierror= ',ierror,' PROGRAM STOPS' - call die(myname_, ': ***FATAL ERROR*** problem reading ens fcst',999) + write(6,*)' PARALLEL_READ_GFSNC_STATE: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + call stop2(999) endif ! get dimension sizes ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len @@ -969,9 +957,20 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig allocate(rwork3d1(nlon,(nlat-2),nsig)) allocate(temp3(nlat,nlon,nsig,nc3d)) k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0 - k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0 do k3=1,nc3d - if (trim(cvars3d(k3))=='cw') then + if(trim(cvars3d(k3))=='t') then + k3t=k3 + call read_vardata(atmges, 'tmp', rwork3d1) + else if(trim(cvars3d(k3))=='sf') then + k3u=k3 + call read_vardata(atmges, 'ugrd', rwork3d1) + else if(trim(cvars3d(k3))=='vp') then + k3v=k3 + call read_vardata(atmges, 'vgrd', rwork3d1) + else if(trim(cvars3d(k3))=='q') then + k3q=k3 + call read_vardata(atmges, 'spfh', rwork3d1) + else if (trim(cvars3d(k3))=='cw') then k3cw=k3 call read_vardata(atmges, 'clwmr', rwork3d1) allocate(rwork3d2(nlon,(nlat-2),nsig)) @@ -979,90 +978,25 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig call read_vardata(atmges, 'icmr', rwork3d2) rwork3d1 = rwork3d1 + rwork3d2 deallocate(rwork3d2) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do + else if(trim(cvars3d(k3))=='oz') then + k3oz=k3 + call read_vardata(atmges, 'o3mr', rwork3d1) else if(trim(cvars3d(k3))=='ql') then - k3ql=k3 call read_vardata(atmges, 'clwmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qi') then - k3qi=k3 call read_vardata(atmges, 'icmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qr') then - k3qr=k3 call read_vardata(atmges, 'rwmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qs') then - k3qs=k3 call read_vardata(atmges, 'snmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qg') then - k3qg=k3 call read_vardata(atmges, 'grle', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='oz') then - k3oz=k3 - call read_vardata(atmges, 'o3mr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='q') then - k3q=k3 - call read_vardata(atmges, 'spfh', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='t') then - k3t=k3 - call read_vardata(atmges, 'tmp', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='sf') then - k3u=k3 - call read_vardata(atmges, 'ugrd', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='vp') then - k3v=k3 - call read_vardata(atmges, 'vgrd', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - end do end if +!$omp parallel do schedule(dynamic,1) private(k,kr) + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do enddo deallocate(rwork3d1) @@ -1070,13 +1004,20 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) & write(6,'(" WARNING, problem with one of k3-")') +!$omp parallel do schedule(dynamic,1) private(k,k3) do k=1,nsig call fillpoles_sv_(temp3(:,:,k,k3u),temp3(:,:,k,k3v),nlon,nlat,clons,slons) end do -! move temp2,temp3 to en_full - kf=0 +! move temp3 to en_full +!$omp parallel do schedule(dynamic,1) private(k3,k,kf,j,jj,i,ii) do k3=1,nc3d + if(k3 /= k3u .and. k3 /= k3v)then + do k=1,nsig + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + end do + end if + kf=(k3-1)*nsig m_cvars3d(k3)=kf+1 do k=1,nsig kf=kf+1 @@ -1095,6 +1036,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig deallocate(temp3) allocate(temp2(nlat,nlon)) allocate(rwork2d(nlon,(nlat-2))) + kf=nc3d*nsig do k2=1,nc2d if(trim(cvars2d(k2))=='ps') then call read_vardata(atmges, 'pressfc', rwork2d) @@ -1104,6 +1046,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig temp2=zero endif +! move temp2 to en_full kf=kf+1 m_cvars2d(k2)=kf jj=jas-1 @@ -1116,6 +1059,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig enddo enddo enddo +! call close_dataset(atmges) deallocate(rwork2d) deallocate(temp2) @@ -1148,7 +1092,6 @@ subroutine fillpoles_ss_(temp,nlon,nlat) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero,one implicit none @@ -1158,6 +1101,7 @@ subroutine fillpoles_ss_(temp,nlon,nlat) integer(i_kind) nlatm1,i real(r_kind) sumn,sums,rnlon + real(r_single) sumn_sing,sums_sing ! Compute mean along southern and northern latitudes sumn=zero @@ -1168,13 +1112,13 @@ subroutine fillpoles_ss_(temp,nlon,nlat) sums=sums+temp(2,i) end do rnlon=one/float(nlon) - sumn=sumn*rnlon - sums=sums*rnlon + sumn_sing=sumn*rnlon + sums_sing=sums*rnlon ! Load means into local work array do i=1,nlon - temp(1,i) =sums - temp(nlat,i)=sumn + temp(1,i) =sums_sing + temp(nlat,i)=sumn_sing end do end subroutine fillpoles_ss_ @@ -1206,13 +1150,12 @@ subroutine fillpoles_sv_(tempu,tempv,nlon,nlat,clons,slons) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero implicit none integer(i_kind),intent(in ) :: nlon,nlat - real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon) + real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon) real(r_kind), intent(in ) :: clons(nlon),slons(nlon) integer(i_kind) i @@ -1267,7 +1210,6 @@ subroutine move1_(work,temp,nlon,nlat) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero implicit none @@ -1317,7 +1259,6 @@ subroutine get_gfs_ens(this,grd,member,ntindex,atm_bundle,iret) ! !$$$ - use kinds, only: i_kind,r_kind use gridmod, only: use_gfs_nemsio, use_gfs_ncio use general_sub2grid_mod, only: sub2grid_info use gsi_4dvar, only: ens_fhrlevs @@ -1421,7 +1362,6 @@ subroutine put_gfs_ens(this,grd,member,ntindex,pert,iret) ! !$$$ - use kinds, only: i_kind use general_sub2grid_mod, only: sub2grid_info use gsi_bundlemod, only: gsi_bundle use gsi_4dvar, only: ens_fhrlevs @@ -1484,7 +1424,6 @@ end subroutine put_gfs_ens subroutine non_gaussian_ens_grid_gfs(this,elats,elons) - use kinds, only: r_kind use hybrid_ensemble_parameters, only: sp_ens implicit none @@ -1516,7 +1455,6 @@ end subroutine non_gaussian_ens_grid_gfs subroutine create_sub2grid_info(s2gi,nsig,npe,s2gi_ref) !> Create temporary communication information object for read ensemble routines - use kinds, only: i_kind use gridmod, only: regional use general_sub2grid_mod, only: sub2grid_info use general_sub2grid_mod, only: general_sub2grid_create_info diff --git a/src/gsi/cplr_gfs_nstmod.f90 b/src/gsi/cplr_gfs_nstmod.f90 index b482085aac..220fa55af1 100644 --- a/src/gsi/cplr_gfs_nstmod.f90 +++ b/src/gsi/cplr_gfs_nstmod.f90 @@ -139,15 +139,15 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr) integer(i_kind):: itnst,itnstp integer(i_kind):: ix,iy,ixp,iyp,j real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11,dtnst,dtnstp - real(r_kind):: tref_00,tref_01,tref_10,tref_11,tr_tmp - real(r_kind):: dt_cool_00,dt_cool_01,dt_cool_10,dt_cool_11 - real(r_kind):: z_c_00,z_c_01,z_c_10,z_c_11 - real(r_kind):: dt_warm_00,dt_warm_01,dt_warm_10,dt_warm_11 - real(r_kind):: z_w_00,z_w_01,z_w_10,z_w_11,z_w_tmp - real(r_kind):: c_0_00,c_0_01,c_0_10,c_0_11 - real(r_kind):: c_d_00,c_d_01,c_d_10,c_d_11 - real(r_kind):: w_0_00,w_0_01,w_0_10,w_0_11 - real(r_kind):: w_d_00,w_d_01,w_d_10,w_d_11 + real(r_kind):: tref_tt,tref2 + real(r_kind):: dt_cool_tt + real(r_kind):: z_c_tt + real(r_kind):: dt_warm_tt + real(r_kind):: z_w_tt + real(r_kind):: c_0_tt + real(r_kind):: c_d_tt + real(r_kind):: w_0_tt + real(r_kind):: w_d_tt real(r_kind):: wgtavg,dlat,dlon logical outside @@ -199,138 +199,137 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr) ! ! Use the time interpolation factors for nst files ! - tref_00 = tref_full (ix ,iy ,itnst)*dtnst + tref_full (ix ,iy ,itnstp)*dtnstp - tref_01 = tref_full (ix ,iyp,itnst)*dtnst + tref_full (ix ,iyp,itnstp)*dtnstp - tref_10 = tref_full (ixp,iy ,itnst)*dtnst + tref_full (ixp,iy ,itnstp)*dtnstp - tref_11 = tref_full (ixp,iyp,itnst)*dtnst + tref_full (ixp,iyp,itnstp)*dtnstp - - dt_cool_00 = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp - dt_cool_01 = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp - dt_cool_10 = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp - dt_cool_11 = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp - - z_c_00 = z_c_full (ix ,iy ,itnst)*dtnst + z_c_full (ix ,iy ,itnstp)*dtnstp - z_c_01 = z_c_full (ix ,iyp,itnst)*dtnst + z_c_full (ix ,iyp,itnstp)*dtnstp - z_c_10 = z_c_full (ixp,iy ,itnst)*dtnst + z_c_full (ixp,iy ,itnstp)*dtnstp - z_c_11 = z_c_full (ixp,iyp,itnst)*dtnst + z_c_full (ixp,iyp,itnstp)*dtnstp - - dt_warm_00 = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp - dt_warm_01 = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp - dt_warm_10 = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp - dt_warm_11 = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp - - z_w_00 = z_w_full (ix ,iy ,itnst)*dtnst + z_w_full (ix ,iy ,itnstp)*dtnstp - z_w_01 = z_w_full (ix ,iyp,itnst)*dtnst + z_w_full (ix ,iyp,itnstp)*dtnstp - z_w_10 = z_w_full (ixp,iy ,itnst)*dtnst + z_w_full (ixp,iy ,itnstp)*dtnstp - z_w_11 = z_w_full (ixp,iyp,itnst)*dtnst + z_w_full (ixp,iyp,itnstp)*dtnstp - - c_0_00 = c_0_full (ix ,iy ,itnst)*dtnst + c_0_full (ix ,iy ,itnstp)*dtnstp - c_0_01 = c_0_full (ix ,iyp,itnst)*dtnst + c_0_full (ix ,iyp,itnstp)*dtnstp - c_0_10 = c_0_full (ixp,iy ,itnst)*dtnst + c_0_full (ixp,iy ,itnstp)*dtnstp - c_0_11 = c_0_full (ixp,iyp,itnst)*dtnst + c_0_full (ixp,iyp,itnstp)*dtnstp - - c_d_00 = c_d_full (ix ,iy ,itnst)*dtnst + c_d_full (ix ,iy ,itnstp)*dtnstp - c_d_01 = c_d_full (ix ,iyp,itnst)*dtnst + c_d_full (ix ,iyp,itnstp)*dtnstp - c_d_10 = c_d_full (ixp,iy ,itnst)*dtnst + c_d_full (ixp,iy ,itnstp)*dtnstp - c_d_11 = c_d_full (ixp,iyp,itnst)*dtnst + c_d_full (ixp,iyp,itnstp)*dtnstp - - w_0_00 = w_0_full (ix ,iy ,itnst)*dtnst + w_0_full (ix ,iy ,itnstp)*dtnstp - w_0_01 = w_0_full (ix ,iyp,itnst)*dtnst + w_0_full (ix ,iyp,itnstp)*dtnstp - w_0_10 = w_0_full (ixp,iy ,itnst)*dtnst + w_0_full (ixp,iy ,itnstp)*dtnstp - w_0_11 = w_0_full (ixp,iyp,itnst)*dtnst + w_0_full (ixp,iyp,itnstp)*dtnstp - - w_d_00 = w_d_full (ix ,iy ,itnst)*dtnst + w_d_full (ix ,iy ,itnstp)*dtnstp - w_d_01 = w_d_full (ix ,iyp,itnst)*dtnst + w_d_full (ix ,iyp,itnstp)*dtnstp - w_d_10 = w_d_full (ixp,iy ,itnst)*dtnst + w_d_full (ixp,iy ,itnstp)*dtnstp - w_d_11 = w_d_full (ixp,iyp,itnst)*dtnst + w_d_full (ixp,iyp,itnstp)*dtnstp ! Interpolate nst variables to obs location (water surface only) wgtavg = zero - tr_tmp = zero + tref2 = zero dt_cool = zero - z_c = zero dt_warm = zero - z_w_tmp = zero + z_c = zero + z_w = zero c_0 = zero c_d = zero w_0 = zero w_d = zero + tz_tr = one + dtw = zero + dtc = zero if (istyp00 == 0)then + tref_tt = tref_full (ix ,iy ,itnst)*dtnst + tref_full (ix ,iy ,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp + z_c_tt = z_c_full (ix ,iy ,itnst)*dtnst + z_c_full (ix ,iy ,itnstp)*dtnstp + z_w_tt = z_w_full (ix ,iy ,itnst)*dtnst + z_w_full (ix ,iy ,itnstp)*dtnstp + c_0_tt = c_0_full (ix ,iy ,itnst)*dtnst + c_0_full (ix ,iy ,itnstp)*dtnstp + c_d_tt = c_d_full (ix ,iy ,itnst)*dtnst + c_d_full (ix ,iy ,itnstp)*dtnstp + w_0_tt = w_0_full (ix ,iy ,itnst)*dtnst + w_0_full (ix ,iy ,itnstp)*dtnstp + w_d_tt = w_d_full (ix ,iy ,itnst)*dtnst + w_d_full (ix ,iy ,itnstp)*dtnstp wgtavg = wgtavg + w00 - tr_tmp = tr_tmp + w00*tref_00 - dt_cool = dt_cool + w00*dt_cool_00 - z_c = z_c + w00*z_c_00 - dt_warm = dt_warm + w00*dt_warm_00 - z_w_tmp = z_w_tmp + w00*z_w_00 - c_0 = c_0 + w00*c_0_00 - c_d = c_d + w00*c_d_00 - w_0 = w_0 + w00*w_0_00 - w_d = w_d + w00*w_d_00 + tref2 = tref2 + w00*tref_tt + dt_cool = dt_cool + w00*dt_cool_tt + dt_warm = dt_warm + w00*dt_warm_tt + z_c = z_c + w00*z_c_tt + z_w = z_w + w00*z_w_tt + c_0 = c_0 + w00*c_0_tt + c_d = c_d + w00*c_d_tt + w_0 = w_0 + w00*w_0_tt + w_d = w_d + w00*w_d_tt endif if(istyp01 == 0)then + tref_tt = tref_full (ix ,iyp,itnst)*dtnst + tref_full (ix ,iyp,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp + z_c_tt = z_c_full (ix ,iyp,itnst)*dtnst + z_c_full (ix ,iyp,itnstp)*dtnstp + z_w_tt = z_w_full (ix ,iyp,itnst)*dtnst + z_w_full (ix ,iyp,itnstp)*dtnstp + c_0_tt = c_0_full (ix ,iyp,itnst)*dtnst + c_0_full (ix ,iyp,itnstp)*dtnstp + c_d_tt = c_d_full (ix ,iyp,itnst)*dtnst + c_d_full (ix ,iyp,itnstp)*dtnstp + w_0_tt = w_0_full (ix ,iyp,itnst)*dtnst + w_0_full (ix ,iyp,itnstp)*dtnstp + w_d_tt = w_d_full (ix ,iyp,itnst)*dtnst + w_d_full (ix ,iyp,itnstp)*dtnstp wgtavg = wgtavg + w01 - tr_tmp = tr_tmp + w01*tref_01 - dt_cool = dt_cool + w01*dt_cool_01 - z_c = z_c + w01*z_c_01 - dt_warm = dt_warm + w01*dt_warm_01 - z_w_tmp = z_w_tmp + w01*z_w_01 - c_0 = c_0 + w01*c_0_01 - c_d = c_d + w01*c_d_01 - w_0 = w_0 + w01*w_0_01 - w_d = w_d + w01*w_d_01 + tref2 = tref2 + w01*tref_tt + dt_cool = dt_cool + w01*dt_cool_tt + dt_warm = dt_warm + w01*dt_warm_tt + z_c = z_c + w01*z_c_tt + z_w = z_w + w01*z_w_tt + c_0 = c_0 + w01*c_0_tt + c_d = c_d + w01*c_d_tt + w_0 = w_0 + w01*w_0_tt + w_d = w_d + w01*w_d_tt end if if(istyp10 == 0)then + tref_tt = tref_full (ixp,iy ,itnst)*dtnst + tref_full (ixp,iy ,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp + z_c_tt = z_c_full (ixp,iy ,itnst)*dtnst + z_c_full (ixp,iy ,itnstp)*dtnstp + z_w_tt = z_w_full (ixp,iy ,itnst)*dtnst + z_w_full (ixp,iy ,itnstp)*dtnstp + c_0_tt = c_0_full (ixp,iy ,itnst)*dtnst + c_0_full (ixp,iy ,itnstp)*dtnstp + c_d_tt = c_d_full (ixp,iy ,itnst)*dtnst + c_d_full (ixp,iy ,itnstp)*dtnstp + w_0_tt = w_0_full (ixp,iy ,itnst)*dtnst + w_0_full (ixp,iy ,itnstp)*dtnstp + w_d_tt = w_d_full (ixp,iy ,itnst)*dtnst + w_d_full (ixp,iy ,itnstp)*dtnstp wgtavg = wgtavg + w10 - tr_tmp = tr_tmp + w10*tref_10 - dt_cool = dt_cool + w10*dt_cool_10 - z_c = z_c + w10*z_c_10 - dt_warm = dt_warm + w10*dt_warm_10 - z_w_tmp = z_w_tmp + w10*z_w_10 - c_0 = c_0 + w10*c_0_10 - c_d = c_d + w10*c_d_10 - w_0 = w_0 + w10*w_0_10 - w_d = w_d + w10*w_d_10 + tref2 = tref2 + w10*tref_tt + dt_cool = dt_cool + w10*dt_cool_tt + dt_warm = dt_warm + w10*dt_warm_tt + z_c = z_c + w10*z_c_tt + z_w = z_w + w10*z_w_tt + c_0 = c_0 + w10*c_0_tt + c_d = c_d + w10*c_d_tt + w_0 = w_0 + w10*w_0_tt + w_d = w_d + w10*w_d_tt end if if(istyp11 == 0)then + tref_tt = tref_full (ixp,iyp,itnst)*dtnst + tref_full (ixp,iyp,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp + z_c_tt = z_c_full (ixp,iyp,itnst)*dtnst + z_c_full (ixp,iyp,itnstp)*dtnstp + z_w_tt = z_w_full (ixp,iyp,itnst)*dtnst + z_w_full (ixp,iyp,itnstp)*dtnstp + c_0_tt = c_0_full (ixp,iyp,itnst)*dtnst + c_0_full (ixp,iyp,itnstp)*dtnstp + c_d_tt = c_d_full (ixp,iyp,itnst)*dtnst + c_d_full (ixp,iyp,itnstp)*dtnstp + w_0_tt = w_0_full (ixp,iyp,itnst)*dtnst + w_0_full (ixp,iyp,itnstp)*dtnstp + w_d_tt = w_d_full (ixp,iyp,itnst)*dtnst + w_d_full (ixp,iyp,itnstp)*dtnstp wgtavg = wgtavg + w11 - tr_tmp = tr_tmp + w11*tref_11 - dt_cool = dt_cool + w11*dt_cool_11 - z_c = z_c + w11*z_c_11 - dt_warm = dt_warm + w11*dt_warm_11 - z_w_tmp = z_w_tmp + w11*z_w_11 - c_0 = c_0 + w11*c_0_11 - c_d = c_d + w11*c_d_11 - w_0 = w_0 + w11*w_0_11 - w_d = w_d + w11*w_d_11 + tref2 = tref2 + w11*tref_tt + dt_cool = dt_cool + w11*dt_cool_tt + dt_warm = dt_warm + w11*dt_warm_tt + z_c = z_c + w11*z_c_tt + z_w = z_w + w11*z_w_tt + c_0 = c_0 + w11*c_0_tt + c_d = c_d + w11*c_d_tt + w_0 = w_0 + w11*w_0_tt + w_d = w_d + w11*w_d_tt end if + if(wgtavg < 1.e-6)return - if(wgtavg > zero)then - tr_tmp = tr_tmp/wgtavg - tref = tr_tmp - - z_w_tmp = z_w_tmp/wgtavg - z_w = z_w_tmp + tref = tref2/wgtavg + z_w = z_w/wgtavg + z_c = z_c/wgtavg - dt_cool = dt_cool/wgtavg - z_c = z_c/wgtavg - dt_warm = dt_warm/wgtavg + if(fac_tsl == 1)then c_0 = c_0/wgtavg c_d = c_d/wgtavg + dt_cool = dt_cool/wgtavg + if(z_c > zero)dtc = dt_cool*(one-min(zob,z_c)/z_c) + else + c_0 = zero + c_d = zero + dt_cool = zero + end if + if(fac_dtl == 1)then w_0 = w_0/wgtavg w_d = w_d/wgtavg + dt_warm = dt_warm/wgtavg + if(z_w > zero)dtw = dt_warm*(one-min(zob,z_w)/z_w) + else + w_0 = zero + w_d = zero + dt_warm = zero + end if - dtw = fac_dtl*dt_warm*(one-min(zob,z_w)/z_w) - if ( z_c > zero ) then - dtc = fac_tsl*dt_cool*(one-min(zob,z_c)/z_c) - else - dtc = zero - endif - call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr) + call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr) - end if end subroutine deter_nst_ !******************************************************************************************* @@ -343,10 +342,10 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr) ! ! dt_warm : diurnal warming amount at the surface ! xz : DTL depth (M) -! c_0 : coefficint 1 to calculate d(Tc)/d(Ts) -! c_d : coefficint 2 to calculate d(Tc)/d(Ts) -! w_0 : coefficint 1 to calculate d(Tw)/d(Ts) -! w_d : coefficint 2 to calculate d(Tw)/d(Ts) +! c_0 : coefficient 1 to calculate d(Tc)/d(Ts) +! c_d : coefficient 2 to calculate d(Tc)/d(Ts) +! w_0 : coefficient 1 to calculate d(Tw)/d(Ts) +! w_d : coefficient 2 to calculate d(Tw)/d(Ts) ! ! output variables ! @@ -354,34 +353,39 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr) use kinds, only: r_kind use constants, only: one,two,half,zero - use gsi_nstcouplermod, only: fac_dtl,fac_tsl real(kind=r_kind), intent(in) :: dt_warm,c_0,c_d,w_0,w_d,zc,zw,z real(kind=r_kind), intent(out) :: tztr ! local variables - real(kind=r_kind) :: c1,c2,c3 + real(kind=r_kind) :: c1,c2,c3,fact - c1 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-(fac_dtl*w_d-fac_tsl*c_d)*z - c2 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-fac_dtl*w_d*z - c3 = one+fac_tsl*two*c_0+fac_dtl*c_d*z tztr = one + c1 = zero + c2 = zero + c3 = zero if ( dt_warm > zero ) then - if ( z <= zc .and. c1 /= zero ) then - tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c1 - elseif ( z > zc .and. z < zw .and. c2 /= zero ) then - tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c2 + fact = (one-w_0+c_0) + if ( z <= zc) then + c1 = one-two*(w_0-c_0)-(w_d-c_d)*z + if ( c1 /= zero ) tztr = fact/c1 + elseif ( z > zc .and. z < zw) then + c2 = one-two*(w_0-c_0)-w_d*z + if (c2 /= zero ) tztr = fact/c2 + else endif - elseif ( dt_warm == zero .and. c3 /= zero ) then - if ( z <= zc ) then - tztr = (one+fac_tsl*c_0)/c3 + elseif (dt_warm == zero) then + if ( z <= zc) then + c3 = one+two*c_0+c_d*z + if (c3 /= zero) tztr = (one+c_0)/c3 endif endif - if ( tztr <= -1.0_r_kind .or. tztr > 4.0_r_kind ) then - write(6,100) fac_dtl,fac_tsl,c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr -100 format('CAL_TZTR compute ',2(i2,1x),12(g13.6,1x),' RESET tztr to 1.0') - tztr = one + if ( tztr < 0.5_r_kind .or. tztr > 1.5_r_kind ) then + write(6,100) c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr +100 format('CAL_TZTR compute ',12(g13.6,1x),' RESET tztr to 0.5 .or. 1.5') + tztr = min(1.5_r_kind,tztr) + tztr = max(0.5_r_kind,tztr) endif end subroutine cal_tztr_ diff --git a/src/gsi/cwhydromod.f90 b/src/gsi/cwhydromod.f90 index a27bba545f..d2bde78129 100644 --- a/src/gsi/cwhydromod.f90 +++ b/src/gsi/cwhydromod.f90 @@ -100,14 +100,23 @@ subroutine cw2hydro(sval,clouds,nclouds) call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) if (istatus/=0) cycle sv_rank3=zero - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - if (clouds(ic)=='ql') sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k)) - if (clouds(ic)=='qi') sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k) + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k)) + end do end do end do - end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k) + end do + end do + end do + end if end do return @@ -174,16 +183,25 @@ subroutine cw2hydro_tl(sval,wbundle,clouds,nclouds) call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) if (istatus/=0) cycle sv_rank3=zero - do k=1,nsig - do j=1,lon2 - do i=1,lat2 -! if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k) -! if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k) - if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k)) - if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k) + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 +! sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k) + sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k)) + end do end do end do - end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 +! sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k) + sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k) + end do + end do + end do + end if end do return @@ -226,8 +244,6 @@ subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds) real(r_kind),pointer,dimension(:,:,:) :: cv_cw ! Get pointer to required control variable -call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) -cv_cw=zero do k=1,nsig do j=1,lon2 @@ -239,25 +255,30 @@ subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds) end do end do +call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) do ic=1,nclouds call gsi_bundlegetpointer (rval,clouds(ic),rv_rank3,istatus) if (istatus/=0) cycle - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - if (clouds(ic)=='ql') then + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*(one-work0(i,j,k)) rv_rank3(i,j,k)=zero - end if - - if (clouds(ic)=='qi') then + end do + end do + end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*work0(i,j,k) rv_rank3(i,j,k)=zero - end if - + end do end do end do - end do + end if + end do return diff --git a/src/gsi/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90 index 3c88aabb2a..e4e77283a4 100644 --- a/src/gsi/deter_sfc_mod.f90 +++ b/src/gsi/deter_sfc_mod.f90 @@ -207,7 +207,6 @@ subroutine deter_sfc(alat,alon,dlat_earth,dlon_earth,obstime,isflg, & sfcpct(istyp10)=sfcpct(istyp10)+w10 sfcpct(istyp11)=sfcpct(istyp11)+w11 - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -517,7 +516,6 @@ subroutine deter_sfc_type(dlat_earth,dlon_earth,obstime,isflg,tsavg) sfcpct(istyp10)=sfcpct(istyp10)+w10 sfcpct(istyp11)=sfcpct(istyp11)+w11 - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1109,7 +1107,7 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,& do i = min_i(j), max_i(j) call reduce2full(i,j,ifull) call time_int_sfc(ifull,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) -!$omp parallel do schedule(dynamic,1)private(jjj,iii,lat_mdl,lon_mdl) +!$omp parallel do schedule(dynamic,1) private(jjj,iii,lat_mdl,lon_mdl) do jjj = 1, subgrid_lengths_y if (y_off(jjj) >= zero) then lat_mdl = (one-y_off(jjj))*rlats_sfc(j)+y_off(jjj)*rlats_sfc(j+1) @@ -1316,7 +1314,6 @@ subroutine deter_sfc_amsre_low(dlat_earth,dlon_earth,isflg,sfcpct) ! sfcpct(3)=min(sfcpct(3),sfcpct(1)) ! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1482,7 +1479,6 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) ! sfcpct(3)=min(sfcpct(3),sfcpct(1)) ! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1986,7 +1982,6 @@ subroutine calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm, & sfcr = sfc_sum%sfcr/count_tot zz = sfc_sum%zz/count_tot - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 ! open water else if(sfcpct(1) > 0.99_r_kind)then diff --git a/src/gsi/evaljgrad.f90 b/src/gsi/evaljgrad.f90 index 788454034d..e66ca11b8c 100644 --- a/src/gsi/evaljgrad.f90 +++ b/src/gsi/evaljgrad.f90 @@ -73,6 +73,7 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean use mpeu_util, only: die use mpl_allreducemod, only: mpl_allreduce +use intradmod, only: setrad implicit none @@ -195,6 +196,7 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) end do qpred=zero_quad +call setrad(sval(1)) ! Compare obs to solution and transpose back to grid (H^T R^{-1} H) call intjo(rval,qpred,sval,sbias) diff --git a/src/gsi/general_read_gfsatm.f90 b/src/gsi/general_read_gfsatm.f90 index 39db75db73..ffdcd90c79 100755 --- a/src/gsi/general_read_gfsatm.f90 +++ b/src/gsi/general_read_gfsatm.f90 @@ -411,6 +411,77 @@ subroutine general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & return end subroutine general_reload2 + +! 2m reload +subroutine general_reload_sfc(grd,g_t2m, g_q2m,g_ps,icount,iflag,work) +! !USES: + use kinds, only: r_kind,i_kind + use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype + use general_sub2grid_mod, only: sub2grid_info + + implicit none +! !INPUT PARAMETERS: + + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(inout) :: icount + integer(i_kind),dimension(npe), intent(inout) :: iflag + real(r_kind),dimension(grd%itotsub),intent(in ) :: work + +! !OUTPUT PARAMETERS: + + real(r_kind),dimension(grd%lat2,grd%lon2), intent( out) :: g_t2m,& + g_q2m, g_ps + +! !DESCRIPTION: version of general_reload, for 2m variables. +! +! !REVISION HISTORY: +! 2023-03-2 Draper +!------------------------------------------------------------------------- + + integer(i_kind) i,j,ij,k + real(r_kind),dimension(grd%lat2*grd%lon2,npe):: sub + + call mpi_alltoallv(work,grd%sendcounts_s,grd%sdispls_s,mpi_rtype,& + sub,grd%recvcounts_s,grd%rdispls_s,mpi_rtype,& + mpi_comm_world,ierror) + +!$omp parallel do schedule(dynamic,1) private(k,i,j,ij) + + do k=1,icount + if ( iflag(k) == 2 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_t2m(i,j)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 3 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_q2m(i,j)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 4 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_ps(i,j)=sub(ij,k) + enddo + enddo + endif + enddo ! do k=1,icount + + icount=0 + iflag=0 + + return + +end subroutine general_reload_sfc + end module gfsreadmod subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & @@ -431,6 +502,7 @@ subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & ! 2014-11-30 todling - genelize interface to handle bundle instead of fields; ! internal code should be generalized ! 2014-12-03 derber - introduce vordivflag, zflag and optimize routines +! 2023-03-23 draper - added option to read sfc files (for 2m variables) ! ! input argument list: ! grd - structure variable containing information about grid @@ -1892,7 +1964,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & use gsi_bundlemod, only: gsi_bundlegetpointer use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& close_dataset, get_dim, read_vardata,get_idate_from_time_units - use gfsreadmod, only: general_reload + use gfsreadmod, only: general_reload, general_reload_sfc implicit none @@ -1910,6 +1982,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & real(r_kind),pointer,dimension(:,:) :: ptr2d real(r_kind),pointer,dimension(:,:,:) :: ptr3d real(r_kind),pointer,dimension(:,:) :: g_ps + real(r_kind),pointer,dimension(:,:) :: g_t2m, g_q2m real(r_kind),pointer,dimension(:,:,:) :: g_vor,g_div,& g_cwmr,g_q,g_oz,g_tv @@ -1942,10 +2015,9 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & logical :: procuse,diff_res,eqspace type(egrid2agrid_parm) :: p_high logical,dimension(1) :: vector - type(Dataset) :: atmges + type(Dataset) :: filges type(Dimension) :: ncdim - - + logical :: read_2m, read_z !****************************************************************************** ! Initialize variables used below @@ -1959,6 +2031,19 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & mype_use=-1 icount=0 procuse=.false. + + if (filename(1:3) == 'sfc') then + read_2m = .true. + read_z = .false. + if ( mype == 0 ) write(6,* ) & + trim(my_name), ': reading 2m variables from ', trim(filename) + else + read_2m = .false. + read_z = zflag + if ( mype == 0 ) write(6,* ) & + trim(my_name), ': reading atmos variables from ', trim(filename) + endif + if ( mype == 0 ) procuse = .true. do i=1,npe if ( grd%recvcounts_s(i-1) > 0 ) then @@ -1992,20 +2077,21 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & if ( procuse ) then - atmges = open_dataset(filename, paropen=.true., mpicomm=mpi_comm_read) + filges = open_dataset(filename, paropen=.true., mpicomm=mpi_comm_read) ! get dimension sizes - ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len - ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len - ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + ncdim = get_dim(filges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(filges, 'grid_yt'); latb = ncdim%len + if (.not. read_2m) & + ncdim = get_dim(filges, 'pfull'); levs = ncdim%len ! get time information - idate = get_idate_from_time_units(atmges) + idate = get_idate_from_time_units(filges) odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day odate(4) = idate(1) !year - call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later + call read_vardata(filges, 'time', fhour) ! might need to change this to attribute later ! depends on model changes from ! Jeff Whitaker fhour = float(nint(fhour)) @@ -2030,11 +2116,13 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & trim(my_name),grd%nlon,lonb !call stop2(101) endif - if ( levs /= grd%nsig ) then - if ( mype == 0 ) write(6, & - '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & - trim(my_name),grd%nsig,levs - call stop2(101) + if (.not. read_2m) then + if ( levs /= grd%nsig ) then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & + trim(my_name),grd%nsig,levs + call stop2(101) + endif endif allocate( spec_vor(sp_a%nc), spec_div(sp_a%nc) ) @@ -2047,8 +2135,8 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & allocate(rwork3d1(lonb,latb,1)) allocate(rwork2d(lonb,latb)) allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb)) - call read_vardata(atmges, 'grid_xt', rlons_tmp) - call read_vardata(atmges, 'grid_yt', rlats_tmp) + call read_vardata(filges, 'grid_xt', rlons_tmp) + call read_vardata(filges, 'grid_yt', rlats_tmp) do j=1,latb rlats(latb+2-j)=deg2rad*rlats_tmp(j) end do @@ -2073,57 +2161,73 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif ! if ( procuse ) ! Get pointer to relevant variables (this should be made flexible and general) - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_nems: ERROR' - write(6,*) 'cannot handle having both sf and div' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_nems: ERROR' - write(6,*) 'cannot handle having both vp and vor' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_nems: ERROR' - write(6,*) 'cannot handle having both t and tv' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - istatus=0 - call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier - if ( istatus /= 0 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_nems: ERROR' - write(6,*) 'Missing some of the required fields' - write(6,*) 'Aborting ... ' - endif - call stop2(999) + if (.not. read_2m) then + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'cannot handle having both sf and div' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'cannot handle having both vp and vor' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'cannot handle having both t and tv' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + else ! read 2m vars + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'t2m',g_t2m ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'q2m',g_q2m ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'Missing 2m required variables' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif endif allocate(g_u(grd%lat2,grd%lon2,grd%nsig),g_v(grd%lat2,grd%lon2,grd%nsig)) allocate(g_z(grd%lat2,grd%lon2)) @@ -2135,8 +2239,8 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! Once on the grid, fields need to be scattered from the full domain to ! sub-domains. - ! Only read Terrain when zflag is true. - if ( zflag ) then + ! Only read Terrain when read_z is true. + if ( read_z ) then icount=icount+1 iflag(icount)=1 @@ -2145,7 +2249,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! Terrain: spectral --> grid transform, scatter to all mpi tasks if (mype==mype_use(icount)) then ! read hs - call read_vardata(atmges, 'hgtsfc', rwork2d) + call read_vardata(filges, 'hgtsfc', rwork2d) if ( diff_res ) then grid_b=rwork2d vector(1)=.false. @@ -2161,415 +2265,498 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & call general_fill_ns(grd,grid,work) endif endif - if ( icount == icm ) then + if ( icount == icm ) then call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & icount,iflag,ilev,work,uvflag,vordivflag) endif endif - icount=icount+1 - iflag(icount)=2 - ilev(icount)=1 + if (.not. read_2m) then + + icount=icount+1 + iflag(icount)=2 + ilev(icount)=1 + + ! Surface pressure: same procedure as terrain + if (mype==mype_use(icount)) then + ! read ps + call read_vardata(filges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + ! Thermodynamic variable: s-->g transform, communicate to all tasks + ! For multilevel fields, each task handles a given level. Periodic + ! mpi_alltoallv calls communicate the grids to all mpi tasks. + ! Finally, the grids are loaded into guess arrays used later in the + ! code. + + do k=1,nlevs + + icount=icount+1 + iflag(icount)=3 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'spfh', rwork3d1, nslice=kr, slicedim=3) + call read_vardata(filges, 'tmp', rwork3d0, nslice=kr, slicedim=3) + rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) + if ( diff_res ) then + grid_b=rwork2d + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + if ( vordivflag .or. .not. uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=4 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Vorticity + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_vor(grd%nlon,nlatm2)) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_vor,work) + deallocate(grid_vor) + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + end do + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=5 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Divergence + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_div(grd%nlon,nlatm2) ) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_div,work) + deallocate(grid_div) + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + end do + endif ! if ( vordivflag .or. .not. uvflag ) + if ( uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=6 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=7 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! V + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + ! Note work_v and work are switched because output must be in work. + call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + endif ! if ( uvflag ) + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=8 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Specific humidity + call read_vardata(filges, 'spfh', rwork3d0, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=9 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) + ! Ozone mixing ratio + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + do k=1,nlevs + icount=icount+1 + iflag(icount)=10 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'icmr', rwork3d1, nslice=kr, slicedim=3) + ! Cloud condensate mixing ratio. + rwork2d = rwork3d0(:,:,1)+rwork3d1(:,:,1) + if ( diff_res ) then + grid_b=rwork2d + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + + endif + + if ( icount == icm .or. k == nlevs ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + enddo ! do k=1,nlevs + else ! read_2m + + icount=icount+1 + iflag(icount)=2 + + ! 2m temperature from sfc file + if (mype==mype_use(icount)) then + call read_vardata(filges, 'tmp2m', rwork2d) + + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + icount=icount + 1 + iflag(icount)=3 + + ! 2m humidity from sfc file + if (mype==mype_use(icount)) then + call read_vardata(filges, 'spfh2m', rwork2d) + + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + icount=icount + 1 + iflag(icount)=4 + + if (mype==mype_use(icount)) then + ! read ps + call read_vardata(filges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + ! not using all procs. doesn't trigger. todo: figure out trigger + ! for when reading fewer vars. + !if ( icount == icm ) then + call general_reload_sfc(grd,g_t2m, g_q2m, g_ps, icount,iflag,work) + !endif + + endif ! read_2m - ! Surface pressure: same procedure as terrain - if (mype==mype_use(icount)) then - ! read ps - call read_vardata(atmges, 'pressfc', rwork2d) - rwork2d = r0_001*rwork2d ! convert Pa to cb - if ( diff_res ) then - vector(1)=.false. - grid_b=rwork2d - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if ( procuse ) then + if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) + call destroy_egrid2agrid(p_high) + deallocate(spec_div,spec_vor) + deallocate(rwork3d1,rwork3d0,clons,slons) + deallocate(rwork2d) + deallocate(grid,grid_v) + call close_dataset(filges) endif + deallocate(work) - ! Thermodynamic variable: s-->g transform, communicate to all tasks - ! For multilevel fields, each task handles a given level. Periodic - ! mpi_alltoallv calls communicate the grids to all mpi tasks. - ! Finally, the grids are loaded into guess arrays used later in the - ! code. - - do k=1,nlevs + ! Convert dry temperature to virtual temperature + !do k=1,grd%nsig + ! do j=1,grd%lon2 + ! do i=1,grd%lat2 + ! g_tv(i,j,k) = g_tv(i,j,k)*(one+fv*g_q(i,j,k)) + ! enddo + ! enddo + !enddo - icount=icount+1 - iflag(icount)=3 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip + ! Load u->div and v->vor slot when uv are used instead + if ( .not. read_2m ) then + if ( uvflag ) then + call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif ! read_2m + if (read_z) then + call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier) + if ( ier == 0 ) ptr2d=g_z + endif - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'spfh', rwork3d1, nslice=kr, slicedim=3) - call read_vardata(atmges, 'tmp', rwork3d0, nslice=kr, slicedim=3) - rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) - if ( diff_res ) then - grid_b=rwork2d - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do + ! Clean up + deallocate(g_z) + deallocate(g_u,g_v) - if ( vordivflag .or. .not. uvflag ) then - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=4 - ilev(icount)=k + ! Print date/time stamp + if ( mype == 0 ) then + write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& + fhour,odate,trim(filename) +700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',& + 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) + endif - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - ! Vorticity - ! Convert grid u,v to div and vor - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - allocate( grid_vor(grd%nlon,nlatm2)) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) - ! Load values into rows for south and north pole - call general_fill_ns(grd,grid_vor,work) - deallocate(grid_vor) - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif + return - end do - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip +end subroutine general_read_gfsatm_nc - icount=icount+1 - iflag(icount)=5 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - ! Divergence - ! Convert grid u,v to div and vor - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - allocate( grid_div(grd%nlon,nlatm2) ) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) - ! Load values into rows for south and north pole - call general_fill_ns(grd,grid_div,work) - deallocate(grid_div) - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - - end do - endif ! if ( vordivflag .or. .not. uvflag ) - if ( uvflag ) then - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=6 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - - icount=icount+1 - iflag(icount)=7 - ilev(icount)=k - - if (mype==mype_use(icount)) then - ! V - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - ! Note work_v and work are switched because output must be in work. - call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - endif ! if ( uvflag ) - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=8 - ilev(icount)=k - - if (mype==mype_use(icount)) then - ! Specific humidity - call read_vardata(atmges, 'spfh', rwork3d0, nslice=kr, slicedim=3) - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - - icount=icount+1 - iflag(icount)=9 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) - ! Ozone mixing ratio - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - - do k=1,nlevs - icount=icount+1 - iflag(icount)=10 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'icmr', rwork3d1, nslice=kr, slicedim=3) - ! Cloud condensate mixing ratio. - rwork2d = rwork3d0(:,:,1)+rwork3d1(:,:,1) - if ( diff_res ) then - grid_b=rwork2d - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - - endif - - if ( icount == icm .or. k == nlevs ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - - enddo ! do k=1,nlevs - - if ( procuse ) then - if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) - call destroy_egrid2agrid(p_high) - deallocate(spec_div,spec_vor) - deallocate(rwork3d1,rwork3d0,clons,slons) - deallocate(rwork2d) - deallocate(grid,grid_v) - call close_dataset(atmges) - endif - deallocate(work) - - ! Convert dry temperature to virtual temperature - !do k=1,grd%nsig - ! do j=1,grd%lon2 - ! do i=1,grd%lat2 - ! g_tv(i,j,k) = g_tv(i,j,k)*(one+fv*g_q(i,j,k)) - ! enddo - ! enddo - !enddo - - ! Load u->div and v->vor slot when uv are used instead - if ( uvflag ) then - call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) - if ( ier == 0 ) then - ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - else ! in this case, overload: return u/v in sf/vp slot - call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) - if ( ier == 0 ) then - ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - endif - endif - else ! in this case, overload: return u/v in sf/vp slot - call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - endif - if (zflag) then - call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier) - if ( ier == 0 ) ptr2d=g_z - endif - - ! Clean up - deallocate(g_z) - deallocate(g_u,g_v) - - ! Print date/time stamp - if ( mype == 0 ) then - write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& - fhour,odate,trim(filename) -700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',& - 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) - endif - - return - -end subroutine general_read_gfsatm_nc subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & gfs_bundle,iret_read) !$$$ subprogram documentation block @@ -2618,7 +2805,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z use gsi_bundlemod, only: gsi_bundlegetpointer use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& close_dataset, get_dim, read_vardata,get_idate_from_time_units - use gfsreadmod, only: general_reload2 + use gfsreadmod, only: general_reload2, general_reload_sfc use ncepnems_io, only: imp_physics implicit none @@ -2637,6 +2824,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z real(r_kind),pointer,dimension(:,:) :: ptr2d real(r_kind),pointer,dimension(:,:,:) :: ptr3d real(r_kind),pointer,dimension(:,:) :: g_ps + real(r_kind),pointer,dimension(:,:) :: g_t2m, g_q2m real(r_kind),pointer,dimension(:,:,:) :: g_vor,g_div,& g_q,g_oz,g_tv real(r_kind),pointer,dimension(:,:,:) :: g_ql,g_qi,g_qr,g_qs,g_qg @@ -2668,8 +2856,9 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z logical :: procuse,diff_res,eqspace type(egrid2agrid_parm) :: p_high logical,dimension(1) :: vector - type(Dataset) :: atmges + type(Dataset) :: filges type(Dimension) :: ncdim + logical :: read_2m, read_z @@ -2685,6 +2874,19 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z mype_use=-1 icount=0 procuse=.false. + + if (filename(1:3) == 'sfc') then + read_2m = .true. + read_z = .false. + if ( mype == 0 ) write(6,* ) & + trim(my_name), ': reading 2m variables from ', trim(filename) + else + read_2m = .false. + read_z = zflag + if ( mype == 0 ) write(6,* ) & + trim(my_name), ': reading atmos variables from ', trim(filename) + endif + if ( mype == 0 ) procuse = .true. do i=1,npe if ( grd%recvcounts_s(i-1) > 0 ) then @@ -2694,26 +2896,26 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z endif enddo icm=icount - allocate( work(grd%itotsub),work_v(grd%itotsub) ) + allocate( work(grd%itotsub)) work=zero - work_v=zero if ( procuse ) then - atmges = open_dataset(filename, paropen=.true.) + filges = open_dataset(filename, paropen=.true.) ! get dimension sizes - ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len - ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len - ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + ncdim = get_dim(filges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(filges, 'grid_yt'); latb = ncdim%len + if (.not. read_2m) & + ncdim = get_dim(filges, 'pfull'); levs = ncdim%len ! get time information - idate = get_idate_from_time_units(atmges) + idate = get_idate_from_time_units(filges) odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day odate(4) = idate(1) !year - call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later + call read_vardata(filges, 'time', fhour) ! might need to change this to attribute later ! depends on model changes from ! Jeff Whitaker fhour = float(nint(fhour)) @@ -2738,11 +2940,13 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z trim(my_name),grd%nlon,lonb !call stop2(101) endif - if ( levs /= grd%nsig ) then - if ( mype == 0 ) write(6, & - '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & - trim(my_name),grd%nsig,levs - call stop2(101) + if (.not. read_2m) then + if ( levs /= grd%nsig ) then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & + trim(my_name),grd%nsig,levs + call stop2(101) + endif endif allocate( spec_vor(sp_a%nc), spec_div(sp_a%nc) ) @@ -2755,8 +2959,8 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z allocate(rwork3d1(lonb,latb,1)) allocate(rwork2d(lonb,latb)) allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb)) - call read_vardata(atmges, 'grid_xt', rlons_tmp) - call read_vardata(atmges, 'grid_yt', rlats_tmp) + call read_vardata(filges, 'grid_xt', rlons_tmp) + call read_vardata(filges, 'grid_yt', rlats_tmp) do j=1,latb rlats(latb+2-j)=deg2rad*rlats_tmp(j) end do @@ -2781,63 +2985,79 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z endif ! if ( procuse ) ! Get pointer to relevant variables (this should be made flexible and general) - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' - write(6,*) 'cannot handle having both sf and div' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' - write(6,*) 'cannot handle having both vp and vor' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' - write(6,*) 'cannot handle having both t and tv' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - istatus=0 - call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier -! call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'ql',g_ql ,ier);istatus1=istatus1+ier - call gsi_bundlegetpointer(gfs_bundle,'qi',g_qi ,ier);istatus1=istatus1+ier - call gsi_bundlegetpointer(gfs_bundle,'qr',g_qr ,ier);istatus1=istatus1+ier - call gsi_bundlegetpointer(gfs_bundle,'qs',g_qs ,ier);istatus1=istatus1+ier - call gsi_bundlegetpointer(gfs_bundle,'qg',g_qg ,ier);istatus1=istatus1+ier -! call gsi_bundlegetpointer(gfs_bundle,'cf',g_cf ,ier);istatus1=istatus1+ier - if ( istatus1 /= 0 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' - write(6,*) 'Missing some of the required hydrometeor fields for imp_physics = ', imp_physics - write(6,*) 'Aborting ... ' - endif - call stop2(999) + if (.not. read_2m) then + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'cannot handle having both sf and div' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'cannot handle having both vp and vor' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'cannot handle having both t and tv' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier + ! call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier + istatus1=0 + call gsi_bundlegetpointer(gfs_bundle,'ql',g_ql ,ier);istatus1=istatus1+ier + call gsi_bundlegetpointer(gfs_bundle,'qi',g_qi ,ier);istatus1=istatus1+ier + call gsi_bundlegetpointer(gfs_bundle,'qr',g_qr ,ier);istatus1=istatus1+ier + call gsi_bundlegetpointer(gfs_bundle,'qs',g_qs ,ier);istatus1=istatus1+ier + call gsi_bundlegetpointer(gfs_bundle,'qg',g_qg ,ier);istatus1=istatus1+ier + ! call gsi_bundlegetpointer(gfs_bundle,'cf',g_cf ,ier);istatus1=istatus1+ier + if ( istatus1 /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'Missing some of the required hydrometeor fields for imp_physics = ', imp_physics + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + else ! read 2m vars + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'t2m',g_t2m ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'q2m',g_q2m ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'Missing 2m required variables' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif endif allocate(g_u(grd%lat2,grd%lon2,grd%nsig),g_v(grd%lat2,grd%lon2,grd%nsig)) @@ -2852,7 +3072,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z ! Only read Terrain when zflag is true. - if ( zflag ) then + if ( read_z ) then icount=icount+1 iflag(icount)=1 @@ -2861,7 +3081,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z ! Terrain: spectral --> grid transform, scatter to all mpi tasks if (mype==mype_use(icount)) then ! read hs - call read_vardata(atmges, 'hgtsfc', rwork2d) + call read_vardata(filges, 'hgtsfc', rwork2d) if ( diff_res ) then grid_b=rwork2d vector(1)=.false. @@ -2883,465 +3103,470 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z endif endif - icount=icount+1 - iflag(icount)=2 - ilev(icount)=1 - - ! Surface pressure: same procedure as terrain - if (mype==mype_use(icount)) then - ! read ps - call read_vardata(atmges, 'pressfc', rwork2d) - rwork2d = r0_001*rwork2d ! convert Pa to cb - if ( diff_res ) then - vector(1)=.false. - grid_b=rwork2d - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - - ! Thermodynamic variable: s-->g transform, communicate to all tasks - ! For multilevel fields, each task handles a given level. Periodic - ! mpi_alltoallv calls communicate the grids to all mpi tasks. - ! Finally, the grids are loaded into guess arrays used later in the - ! code. - - do k=1,nlevs - - icount=icount+1 - iflag(icount)=3 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'spfh', rwork3d1, nslice=kr, slicedim=3) - call read_vardata(atmges, 'tmp', rwork3d0, nslice=kr, slicedim=3) - rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) - if ( diff_res ) then - grid_b=rwork2d - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - - if ( vordivflag .or. .not. uvflag ) then - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=4 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - ! Vorticity - ! Convert grid u,v to div and vor - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - allocate( grid_vor(grd%nlon,nlatm2)) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) - ! Load values into rows for south and north pole - call general_fill_ns(grd,grid_vor,work) - deallocate(grid_vor) - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - - icount=icount+1 - iflag(icount)=5 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - ! Divergence - ! Convert grid u,v to div and vor - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - allocate( grid_div(grd%nlon,nlatm2) ) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) - ! Load values into rows for south and north pole - call general_fill_ns(grd,grid_div,work) - deallocate(grid_div) - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - - end do - endif ! if ( vordivflag .or. .not. uvflag ) - - if ( uvflag ) then - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=6 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - - icount=icount+1 - iflag(icount)=7 - ilev(icount)=k - - if (mype==mype_use(icount)) then - ! V - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - ! Note work_v and work are switched because output must be in work. - call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - endif ! if ( uvflag ) - - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=8 - ilev(icount)=k - - if (mype==mype_use(icount)) then - ! Specific humidity - call read_vardata(atmges, 'spfh', rwork3d0, nslice=kr, slicedim=3) - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - - icount=icount+1 - iflag(icount)=9 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) - ! Ozone mixing ratio - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - - do k=1,nlevs - icount=icount+1 - iflag(icount)=10 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) - ! Cloud liquid water mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs - - do k=1,nlevs - icount=icount+1 - iflag(icount)=11 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'icmr', rwork3d0, nslice=kr, slicedim=3) - ! Cloud ice water mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs - - do k=1,nlevs - icount=icount+1 - iflag(icount)=12 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'rwmr', rwork3d0, nslice=kr, slicedim=3) - ! Rain water mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs - - do k=1,nlevs - icount=icount+1 - iflag(icount)=13 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'snmr', rwork3d0, nslice=kr, slicedim=3) - ! Snow water mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs - - do k=1,nlevs - icount=icount+1 - iflag(icount)=14 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'grle', rwork3d0, nslice=kr, slicedim=3) - ! Graupel mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm .or. k==nlevs) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs + if (.not. read_2m) then + + allocate( work_v(grd%itotsub) ) + work_v=zero + + icount=icount+1 + iflag(icount)=2 + ilev(icount)=1 + + ! Surface pressure: same procedure as terrain + if (mype==mype_use(icount)) then + ! read ps + call read_vardata(filges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + ! Thermodynamic variable: s-->g transform, communicate to all tasks + ! For multilevel fields, each task handles a given level. Periodic + ! mpi_alltoallv calls communicate the grids to all mpi tasks. + ! Finally, the grids are loaded into guess arrays used later in the + ! code. + + do k=1,nlevs + + icount=icount+1 + iflag(icount)=3 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'spfh', rwork3d1, nslice=kr, slicedim=3) + call read_vardata(filges, 'tmp', rwork3d0, nslice=kr, slicedim=3) + rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) + if ( diff_res ) then + grid_b=rwork2d + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + if ( vordivflag .or. .not. uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=4 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Vorticity + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_vor(grd%nlon,nlatm2)) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_vor,work) + deallocate(grid_vor) + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=5 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Divergence + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_div(grd%nlon,nlatm2) ) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_div,work) + deallocate(grid_div) + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + end do + endif ! if ( vordivflag .or. .not. uvflag ) + + if ( uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=6 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=7 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! V + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + ! Note work_v and work are switched because output must be in work. + call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + endif ! if ( uvflag ) + + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=8 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Specific humidity + call read_vardata(filges, 'spfh', rwork3d0, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=9 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) + ! Ozone mixing ratio + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + do k=1,nlevs + icount=icount+1 + iflag(icount)=10 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) + ! Cloud liquid water mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs + + do k=1,nlevs + icount=icount+1 + iflag(icount)=11 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'icmr', rwork3d0, nslice=kr, slicedim=3) + ! Cloud ice water mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs + + do k=1,nlevs + icount=icount+1 + iflag(icount)=12 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'rwmr', rwork3d0, nslice=kr, slicedim=3) + ! Rain water mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs + + do k=1,nlevs + icount=icount+1 + iflag(icount)=13 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'snmr', rwork3d0, nslice=kr, slicedim=3) + ! Snow water mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs + + do k=1,nlevs + icount=icount+1 + iflag(icount)=14 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'grle', rwork3d0, nslice=kr, slicedim=3) + ! Graupel mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm .or. k==nlevs) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs ! do k=1,nlevs ! icount=icount+1 @@ -3350,7 +3575,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z ! kr = levs+1-k ! netcdf is top to bottom, need to flip ! ! if (mype==mype_use(icount)) then -! call read_vardata(atmges, 'cld_amt', rwork3d0, nslice=kr, slicedim=3) +! call read_vardata(filges, 'cld_amt', rwork3d0, nslice=kr, slicedim=3) ! ! Cloud amount (cloud fraction). ! if ( diff_res ) then ! grid_b=rwork3d0(:,:,1) @@ -3374,6 +3599,87 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z ! endif ! enddo ! do k=1,nlevs + else ! read_2m + + icount=icount+1 + iflag(icount)=2 + + ! 2m temperature from sfc file + if (mype==mype_use(icount)) then + call read_vardata(filges, 'tmp2m', rwork2d) + + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + icount=icount + 1 + iflag(icount)=3 + + ! 2m humidity from sfc file + if (mype==mype_use(icount)) then + call read_vardata(filges, 'spfh2m', rwork2d) + + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + icount=icount + 1 + iflag(icount)=4 + + if (mype==mype_use(icount)) then + ! read ps + call read_vardata(filges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + ! not necessarily using all assigned tasks (fewer vars), so below doesn't trigger. + ! todo: figure out what icm should be here. + !if ( icount == icm ) then + call general_reload_sfc(grd,g_t2m, g_q2m, g_ps, icount,iflag,work) + !endif + + endif ! read_2m + + + if ( procuse ) then if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) call destroy_egrid2agrid(p_high) @@ -3381,9 +3687,10 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z deallocate(rwork3d1,rwork3d0,clons,slons) deallocate(rwork2d) deallocate(grid,grid_v) - call close_dataset(atmges) + call close_dataset(filges) endif - deallocate(work, work_v) + deallocate(work) + if (allocated(work_v)) deallocate(work_v) ! Convert dry temperature to virtual temperature !do k=1,grd%nsig @@ -3395,27 +3702,29 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z !enddo ! Load u->div and v->vor slot when uv are used instead - if ( uvflag ) then - call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) - if ( ier == 0 ) then - ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - else ! in this case, overload: return u/v in sf/vp slot - call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) - if ( ier == 0 ) then - ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - endif - endif - else ! in this case, overload: return u/v in sf/vp slot - call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - endif - if (zflag) then + if ( .not. read_2m ) then + if ( uvflag ) then + call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif !read_2m + if (read_z) then call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier) if ( ier == 0 ) ptr2d=g_z endif @@ -3428,7 +3737,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z if ( mype == 0 ) then write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& fhour,odate,trim(filename) -700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',& +700 format('GENERAL_READ_GFSATM_ALLHYDRO_NC: read lonb,latb,levs=',& 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) endif diff --git a/src/gsi/general_specmod.f90 b/src/gsi/general_specmod.f90 index 20feae98de..c90187bf70 100644 --- a/src/gsi/general_specmod.f90 +++ b/src/gsi/general_specmod.f90 @@ -317,7 +317,7 @@ subroutine general_spec_multwgt(sp,spcwrk,spcwgt) real(r_kind),dimension(sp%nc),intent(inout) :: spcwrk real(r_kind),dimension(0:sp%jcap),intent(in) :: spcwgt - integer(i_kind) ii1,l,m,jmax,ks,n + integer(i_kind) l,jmax,ks,n !! Code borrowed from spvar in splib jmax=sp%jcap diff --git a/src/gsi/genqsat.f90 b/src/gsi/genqsat.f90 index ed0eb152e6..bc33187497 100644 --- a/src/gsi/genqsat.f90 +++ b/src/gsi/genqsat.f90 @@ -145,9 +145,9 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) esw = psat * (tr**xa) * exp(xb*(one-tr)) esi = psat * (tr**xai) * exp(xbi*(one-tr)) w = (tdry - tmix) / (ttp - tmix) -! es = w * esw + (one-w) * esi - es = w * psat * (tr**xa) * exp(xb*(one-tr)) & - + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr)) + es = w * esw + (one-w) * esi +! es = w * psat * (tr**xa) * exp(xb*(one-tr)) & +! + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr)) endif diff --git a/src/gsi/gesinfo.F90 b/src/gsi/gesinfo.F90 index 792900b628..0aefd34c76 100644 --- a/src/gsi/gesinfo.F90 +++ b/src/gsi/gesinfo.F90 @@ -148,7 +148,7 @@ subroutine gesinfo write(filename,'("sigf",i2.2)')nhr_assimilation inquire(file=filename,exist=fexist) if(.not.fexist) then - write(6,*)' GESINFO: ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + write(6,*)' GESINFO: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' call stop2(99) stop end if @@ -339,12 +339,12 @@ subroutine gesinfo ! open the netCDF file atmges = open_dataset(filename,errcode=iret) if (iret /=0) then - write(6,*)'GESINFO: ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + write(6,*)'GESINFO: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' call stop2(99) endif sfcges = open_dataset(sfilename,errcode=iret) if (iret /=0) then - write(6,*)'GESINFO: ***ERROR*** ',trim(sfilename),' NOT AVAILABLE: PROGRAM STOPS' + write(6,*)'GESINFO: ***FATAL ERROR*** ',trim(sfilename),' NOT AVAILABLE: PROGRAM STOPS' call stop2(99) endif ! get dimension sizes @@ -451,7 +451,7 @@ subroutine gesinfo ! Check for consistency with namelist settings if (gfshead%jcap/=jcap_b.and..not.regional .or. gfshead%levs/=nsig) then if (gfshead%levs/=nsig) then - write(6,*)'GESINFO: ***ERROR*** guess levels inconsistent with namelist' + write(6,*)'GESINFO: ***FATAL ERROR*** guess levels inconsistent with namelist' write(6,*)' guess nsig=',gfshead%levs write(6,*)' namelist nsig=',nsig fatal = .true. @@ -466,7 +466,7 @@ subroutine gesinfo fatal = .false. else if ( mype == mype_out ) & - write(6,*)'GESINFO: ***ERROR*** guess jcap inconsistent with namelist' + write(6,*)'GESINFO: ***FATAL ERROR*** guess jcap inconsistent with namelist' fatal = .true. endif if ( mype == mype_out ) & diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index 1cb7586a89..e244fa9f53 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -64,6 +64,7 @@ subroutine get_gefs_ensperts_dualres use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: gsi_bundledestroy use gsi_bundlemod, only: gsi_gridcreate + use gsi_bundlemod, only : assignment(=) use gsi_enscouplermod, only: gsi_enscoupler_get_user_nens use gsi_enscouplermod, only: gsi_enscoupler_create_sub2grid_info use gsi_enscouplermod, only: gsi_enscoupler_destroy_sub2grid_info @@ -94,7 +95,7 @@ subroutine get_gefs_ensperts_dualres ! integer(i_kind) il,jl logical ice,hydrometeor type(sub2grid_info) :: grd_tmp - integer(i_kind) :: ig0,ig + integer(i_kind) :: ig ! Create perturbations grid and get variable names from perturbations if(en_perts(1,1,1)%grid%im/=grd_ens%lat2.or. & @@ -150,6 +151,7 @@ subroutine get_gefs_ensperts_dualres call gsi_bundlecreate(en_read(n),en_perts(1,1,1)%grid,'ensemble member',istatus,names2d=cvars2d,names3d=cvars3d) if ( istatus /= 0 ) & call die('get_gefs_ensperts_dualres',': trouble creating en_read bundle, istatus =',istatus) + en_read(n) = zero end do ! allocate(z(im,jm)) @@ -158,14 +160,6 @@ subroutine get_gefs_ensperts_dualres ! sst2=zero ! for now, sst not used in ensemble perturbations, so if sst array is called for ! then sst part of en_perts will be zero when sst2=zero -!$omp parallel do schedule(dynamic,1) private(m,n) - do m=1,ntlevs_ens - do n=1,n_ens - en_perts(n,1,m)%valuesr4=zero_single - end do - end do - - ntlevs_ens_loop: do m=1,ntlevs_ens call gsi_enscoupler_get_user_Nens(grd_tmp,n_ens,m,en_read,iret) @@ -180,28 +174,39 @@ subroutine get_gefs_ensperts_dualres cycle endif + en_bar%values=zero if (.not.q_hyb_ens) then !use RH - kap1=rd_over_cp+one - kapr=one/rd_over_cp - do n=1,n_ens + allocate(pri(im,jm,km+1)) + allocate(prsl(im,jm,km),tsen(im,jm,km)) + allocate(qs(im,jm,km)) + end if + do n=1,n_ens + call gsi_bundlegetpointer(en_read(n),'q' ,q ,ier);istatus=istatus+ier + do k=1,km + do j=1,jm + do i=1,im + q(i,j,k)=max(q(i,j,k),zero) + end do + end do + end do + if (.not.q_hyb_ens) then !use RH call gsi_bundlegetpointer(en_read(n),'ps',ps,ier);istatus=ier call gsi_bundlegetpointer(en_read(n),'t' ,tv,ier);istatus=istatus+ier - call gsi_bundlegetpointer(en_read(n),'q' ,q ,ier);istatus=istatus+ier ! Compute RH ! Get 3d pressure field now on interfaces - allocate(pri(im,jm,km+1)) call general_getprs_glb(ps,tv,pri) - allocate(prsl(im,jm,km),tsen(im,jm,km),qs(im,jm,km)) ! Get sensible temperature and 3d layer pressure if (idsl5 /= 2) then + kap1=rd_over_cp+one + kapr=one/rd_over_cp !$omp parallel do schedule(dynamic,1) private(k,j,i) do k=1,km do j=1,jm do i=1,im prsl(i,j,k)=((pri(i,j,k)**kap1-pri(i,j,k+1)**kap1)/& (kap1*(pri(i,j,k)-pri(i,j,k+1))))**kapr - tsen(i,j,k)= tv(i,j,k)/(one+fv*max(zero,q(i,j,k))) + tsen(i,j,k)= tv(i,j,k)/(one+fv*q(i,j,k)) end do end do end do @@ -211,12 +216,11 @@ subroutine get_gefs_ensperts_dualres do j=1,jm do i=1,im prsl(i,j,k)=(pri(i,j,k)+pri(i,j,k+1))*half - tsen(i,j,k)= tv(i,j,k)/(one+fv*max(zero,q(i,j,k))) + tsen(i,j,k)= tv(i,j,k)/(one+fv*q(i,j,k)) end do end do end do end if - deallocate(pri) ice=.true. iderivative=0 @@ -228,14 +232,7 @@ subroutine get_gefs_ensperts_dualres end do end do end do - deallocate(tsen,prsl,qs) - enddo - end if - - - en_bar%values=zero - - n_ens_loop: do n=1,n_ens + end if !$omp parallel do schedule(dynamic,1) private(i,k,j,ic3,hydrometeor,istatus,p3) @@ -246,14 +243,14 @@ subroutine get_gefs_ensperts_dualres trim(cvars3d(ic3))=='qs' .or. trim(cvars3d(ic3))=='qg' .or. & trim(cvars3d(ic3))=='qh' - call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m - call stop2(999) - end if if ( hydrometeor ) then + call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m + call stop2(999) + end if do k=1,km do j=1,jm do i=1,im @@ -263,13 +260,17 @@ subroutine get_gefs_ensperts_dualres end do else if ( trim(cvars3d(ic3)) == 'oz' .and. oz_univ_static ) then + call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m + call stop2(999) + end if p3 = zero end if end do !c3d do i=1,nelen - en_perts(n,1,m)%valuesr4(i)=en_read(n)%values(i) - en_bar%values(i)=en_bar%values(i)+en_read(n)%values(i) + en_bar%values(i)=en_bar%values(i)+en_read(n)%values(i)*bar_norm end do @@ -279,14 +280,14 @@ subroutine get_gefs_ensperts_dualres ! know who would want to commented out code below but be mindful ! of how it interacts with option sst_staticB, please - Todling. - end do n_ens_loop ! end do over ensemble - - do i=1,nelen - en_bar%values(i)=en_bar%values(i)*bar_norm - end do + end do ! end do over ensembles + if (.not.q_hyb_ens) then !use RH + deallocate(pri) + deallocate(tsen,prsl) + deallocate(qs) + end if ! Before converting to perturbations, get ensemble spread - !-- if (m == 1 .and. write_ens_sprd ) call ens_spread_dualres(en_bar,1) !!! it is not clear of the next statement is thread/$omp safe. if (write_ens_sprd ) call ens_spread_dualres(en_bar,m) @@ -297,7 +298,6 @@ subroutine get_gefs_ensperts_dualres ! Copy pbar to module array. ps_bar may be needed for vertical localization ! in terms of scale heights/normalized p/p -! Convert to mean do j=1,jm do i=1,im ps_bar(i,j,m)=x2(i,j) @@ -309,7 +309,7 @@ subroutine get_gefs_ensperts_dualres !$omp parallel do schedule(dynamic,1) private(n,i,ic3,ipic,k,j) do n=1,n_ens do i=1,nelen - en_perts(n,1,m)%valuesr4(i)=en_perts(n,1,m)%valuesr4(i)-en_bar%values(i) + en_perts(n,1,m)%valuesr4(i)=en_read(n)%values(i)-en_bar%values(i) end do if(.not. q_hyb_ens) then do ic3=1,nc3d @@ -332,6 +332,7 @@ subroutine get_gefs_ensperts_dualres end do end do ntlevs_ens_loop !end do over bins + call gsi_bundledestroy(en_bar,istatus) if(nsclgrp > 1 .and. global_spectral_filter_sd) then do m=1,ntlevs_ens do n=1,n_ens @@ -725,8 +726,6 @@ subroutine general_getprs_glb(ps,tv,prs) real(r_kind),parameter:: ten = 10.0_r_kind - kapr=one/rd_over_cp - if (regional) then if(wrf_nmm_regional.or.nems_nmmb_regional) then do k=1,nsig+1 @@ -767,32 +766,45 @@ subroutine general_getprs_glb(ps,tv,prs) end do endif else - k=1 - k2=nsig+1 - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ps(i,j) - prs(i,j,k2)=zero - end do - end do if (idvc5 /= 3) then !$omp parallel do schedule(dynamic,1) private(k,j,i) - do k=2,nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ak5(k)+bk5(k)*ps(i,j) + do k=1,nsig + if(k == 1)then + k2=nsig+1 + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ps(i,j) + prs(i,j,k2)=zero + end do end do - end do + else + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ak5(k)+bk5(k)*ps(i,j) + end do + end do + end if end do else + kapr=one/rd_over_cp !$omp parallel do schedule(dynamic,1) private(k,j,i,trk) - do k=2,nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr - prs(i,j,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk) + do k=1,nsig + if(k == 1)then + k2=nsig+1 + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ps(i,j) + prs(i,j,k2)=zero + end do end do - end do + else + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr + prs(i,j,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk) + end do + end do + end if end do end if end if diff --git a/src/gsi/get_gefs_for_regional.f90 b/src/gsi/get_gefs_for_regional.f90 index a076f0ccfd..43a88ef300 100644 --- a/src/gsi/get_gefs_for_regional.f90 +++ b/src/gsi/get_gefs_for_regional.f90 @@ -41,7 +41,7 @@ subroutine get_gefs_for_regional fv3_regional use hybrid_ensemble_parameters, only: region_lat_ens,region_lon_ens use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen - use hybrid_ensemble_parameters, only: n_ens_gfs,grd_ens,grd_a1,grd_e1,p_e2a,uv_hyb_ens,dual_res + use hybrid_ensemble_parameters, only: n_ens_gfs,weight_ens_gfs,grd_ens,grd_a1,grd_e1,p_e2a,uv_hyb_ens,dual_res use hybrid_ensemble_parameters, only: full_ensemble,q_hyb_ens,l_ens_in_diff_time,write_ens_sprd use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path,jcap_ens use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d @@ -1311,7 +1311,7 @@ subroutine get_gefs_for_regional ! 2*J_b = x^T * (beta1*B + beta2*P_ens)^(-1) * x ! where P_ens is the ensemble covariance which is the sum of outer products of the ! ensemble perturbations (unnormalized) divided by n_ens-1 (or n_ens, depending on who you read). - sig_norm=sqrt(one/max(one,n_ens_temp-one)) + sig_norm=sqrt(weight_ens_gfs/max(one,n_ens_temp-one)) ! if(n_ens_temp==n_ens.and.n==n_ens+1) sig_norm=one ! if(n==1 .or. n==2 .or. n==50) then diff --git a/src/gsi/getsiga.f90 b/src/gsi/getsiga.f90 index 788e0652d7..ad47017be1 100644 --- a/src/gsi/getsiga.f90 +++ b/src/gsi/getsiga.f90 @@ -198,6 +198,7 @@ subroutine view_cv_ad (xhat,mydate,filename,readcv) use state_vectors, only: allocate_state,deallocate_state,prt_state_norms use bias_predictors, only: predictors,allocate_preds,deallocate_preds,assignment(=) use bias_predictors, only: read_preds +use control2state_mod, only: control2state_ad implicit none type(control_vector) :: xhat integer(i_kind), intent(in) :: mydate(5) ! as in iadate or ibdate, or similar diff --git a/src/gsi/gridmod.F90 b/src/gsi/gridmod.F90 index 928b9e9c43..559a3f576d 100644 --- a/src/gsi/gridmod.F90 +++ b/src/gsi/gridmod.F90 @@ -130,6 +130,7 @@ module gridmod public :: vectosub public :: reload public :: strip_periodic + public :: minmype ! set passed variables to public public :: nnnn1o,iglobal,itotsub,ijn,ijn_s,lat2,lon2,lat1,lon1,nsig,nsig_soil @@ -267,6 +268,7 @@ module gridmod integer(i_kind) jcap ! spectral triangular truncation of ncep global analysis integer(i_kind) jcap_b ! spectral triangular truncation of ncep global background integer(i_kind) nthreads ! number of threads used (currently only used in calctends routines) + integer(i_kind) minmype ! processor with minimum size subdomain logical periodic ! logical flag for periodic e/w domains @@ -574,7 +576,7 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) integer(i_kind) n3d,n2d,nvars,tid,nth integer(i_kind) ipsf,ipvp,jpsf,jpvp,isfb,isfe,ivpb,ivpe integer(i_kind) istatus,icw,iql,iqi - integer(i_kind) icw_cv,iql_cv,iqi_cv + integer(i_kind) icw_cv,iql_cv,iqi_cv,minmax logical,allocatable,dimension(:):: vector logical print_verbose @@ -687,6 +689,8 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) periodic=grd_a%periodic + minmype=0 + minmax=grd_a%ilat1(1)*grd_a%jlon1(1) do i=1,npe istart(i) =grd_a%istart(i) jstart(i) =grd_a%jstart(i) @@ -699,7 +703,12 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) displs_s(i) =grd_a%displs_s(i) ijn(i) =grd_a%ijn(i) displs_g(i) =grd_a%displs_g(i) + if(grd_a%ilat1(i)*grd_a%jlon1(i)< minmax)then + minmax=grd_a%ilat1(i)*grd_a%jlon1(i) + minmype=i-1 + end if end do + if(mype == minmype) write(6,*) ' minmype = ',minmype !#omp parallel private(nth,tid) nth = omp_get_max_threads() diff --git a/src/gsi/gsi_dbzOper.F90 b/src/gsi/gsi_dbzOper.F90 index 74d9bdf65d..4a63d0995f 100644 --- a/src/gsi/gsi_dbzOper.F90 +++ b/src/gsi/gsi_dbzOper.F90 @@ -83,6 +83,10 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use jfunc , only: jiter use mpeu_util, only: die + + use directDA_radaruse_mod, only: l_use_dbz_directDA + use obsmod, only: dirname, ianldate + implicit none class(dbzOper ), intent(inout):: self integer(i_kind), intent(in):: lunin @@ -99,8 +103,25 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) character(len=len_isis ):: isis integer(i_kind):: nreal,nchanl,ier,nele logical:: diagsave + integer(i_kind):: lu_diag + character(128):: diag_file + character(80):: string + + if(nobs == 0) then - if(nobs == 0) return + if( (mype == 0) .and. init_pass .and. (.not. l_use_dbz_directDA) ) then + write(string,600) jiter +600 format('radardbz_',i2.2) + diag_file=trim(dirname) // trim(string) + write(6,*) 'write ianldate to ', diag_file + open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + write(lu_diag) ianldate + close(lu_diag) + endif + + return + + endif read(lunin,iostat=ier) obstype,isis,nreal,nchanl if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index 1658c83bf4..b98cd2d0da 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -124,7 +124,6 @@ constants.f90 control2model.f90 control2model_ad.f90 control2state.f90 -control2state_ad.f90 control_vectors.f90 convb_ps.f90 convb_q.f90 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 2edde4723f..4fcb2aba1d 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -538,7 +538,7 @@ subroutine read_fv3_files(mype) ! Declare local variables logical(4) fexist character(6) filename - character(14) filenames + character(19) filenames integer(i_kind) in_unit integer(i_kind) i,j,iwan,npem1 integer(i_kind) nhr_half @@ -573,11 +573,19 @@ subroutine read_fv3_files(mype) in_unit=15 iwan=0 !WWWWWW setup for one first guess file for now - do i=0,9 !place holder for FGAT + do i=0,9 !place holder for FGAT if ( i == 6 ) then - write(filenames,"(A11)") 'fv3_dynvars' + if(fv3_io_layout_y > 1) then + write(filenames,"(A16)") 'fv3_dynvars.0000' + else + write(filenames,"(A11)") 'fv3_dynvars' + endif else - write(filenames,"(A12,I2.2)") 'fv3_dynvars_',i + if(fv3_io_layout_y > 1) then + write(filenames,"(A17,I2.2)") 'fv3_dynvars.0000_',i + else + write(filenames,"(A12,I2.2)") 'fv3_dynvars_',i + endif endif INQUIRE(FILE=filenames, EXIST=fexist) if(.not.fexist) cycle @@ -1119,7 +1127,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if (allocated(fv3lam_io_dynmetvars2d_nouv)) & write(6,*)' fv3lam_io_dynmetvars2d_nouv is ',(trim(fv3lam_io_dynmetvars2d_nouv(i)), i=1,ndynvario2d) if (allocated(fv3lam_io_tracermetvars2d_nouv))& - write(6,*)'fv3lam_io_dynmetvars2d_nouv is ',(trim(fv3lam_io_dynmetvars2d_nouv(i)),i=1,ntracerio3d) + write(6,*)'fv3lam_io_tracermetvars2d_nouv is ',(trim(fv3lam_io_tracermetvars2d_nouv(i)),i=1,ntracerio2d) endif if (laeroana_fv3cmaq) then @@ -1783,6 +1791,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) ! abstract: read in 2d fields from fv3_sfcdata file in mype_2d ! Scatter the field to each PE ! program history log: +! 2023-02-14 Hu - Bug fix for read in subdomain surface restart files +! ! input argument list: ! it - time index for 2d fields ! @@ -1814,7 +1824,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) real(r_kind),intent(in),dimension(:,:),pointer::ges_q2m type (type_fv3regfilenameg),intent(in) :: fv3filenamegin character(len=max_varname_length) :: name - integer(i_kind),allocatable,dimension(:):: dim_id,dim + integer(i_kind),allocatable,dimension(:):: dim real(r_kind),allocatable,dimension(:):: work real(r_kind),allocatable,dimension(:,:):: a real(r_kind),allocatable,dimension(:,:,:):: sfcn2d @@ -1902,40 +1912,24 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) write(*,*) "wrong dimension number ndim =",ndim call stop2(119) endif - if(allocated(dim_id )) deallocate(dim_id ) - allocate(dim_id(ndim)) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - iret=nf90_inquire_variable(gfile_loc_layout(nio),i,dimids=dim_id) - if(allocated(sfc )) deallocate(sfc ) - if(dim(dim_id(1)) == nx .and. dim(dim_id(2))==ny_layout_len(nio)) then - if(ndim >=3) then - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - iret=nf90_get_var(gfile_loc_layout(nio),i,sfc) - else if (ndim == 2) then - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),1)) - iret=nf90_get_var(gfile_loc_layout(nio),i,sfc(:,:,1)) - endif - else - write(*,*) "Mismatch dimension in surfacei reading:",nx,ny_layout_len(nio),dim(dim_id(1)),dim(dim_id(2)) - call stop2(119) - endif - sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc(:,:,1) + if(allocated(sfc )) deallocate(sfc ) + allocate(sfc(nx,ny_layout_len(nio),1)) + if(ndim >=3) then + iret=nf90_get_var(gfile_loc_layout(nio),i,sfc) + else if (ndim == 2) then + iret=nf90_get_var(gfile_loc_layout(nio),i,sfc(:,:,1)) + endif + sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc(:,:,1) enddo else - iret=nf90_inquire_variable(gfile_loc,i,dimids=dim_id) if(allocated(sfc )) deallocate(sfc ) - if(dim(dim_id(1)) == nx .and. dim(dim_id(2))==ny) then - if(ndim >=3) then !the block of 10 lines is compied from GSL gsi. - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - iret=nf90_get_var(gfile_loc,i,sfc) - else if (ndim == 2) then - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),1)) - iret=nf90_get_var(gfile_loc,i,sfc(:,:,1)) - endif - else - write(*,*) "Mismatch dimension in surfacei reading:",nx,ny,dim(dim_id(1)),dim(dim_id(2)) - call stop2(119) + allocate(sfc(nx,ny,1)) + if(ndim >=3) then + iret=nf90_get_var(gfile_loc,i,sfc) + else if (ndim == 2) then + iret=nf90_get_var(gfile_loc,i,sfc(:,:,1)) endif sfc_fulldomain(:,:)=sfc(:,:,1) endif @@ -1997,19 +1991,16 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) iret=nf90_inquire_variable(gfile_loc,k,name,len) if(trim(name)=='PHIS' .or. trim(name)=='phis' ) then iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) - if(allocated(dim_id )) deallocate(dim_id ) - allocate(dim_id(ndim)) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - iret=nf90_inquire_variable(gfile_loc_layout(nio),k,dimids=dim_id) if(allocated(sfc1 )) deallocate(sfc1 ) - allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) ) + allocate(sfc1(nx,ny_layout_len(nio)) ) iret=nf90_get_var(gfile_loc_layout(nio),k,sfc1) sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc1 enddo else - iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id) - allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) ) + if(allocated(sfc1 )) deallocate(sfc1 ) + allocate(sfc1(nx,ny) ) iret=nf90_get_var(gfile_loc,k,sfc1) sfc_fulldomain=sfc1 endif @@ -2040,7 +2031,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) end do end do - if(allocated(sfc1) .and. allocated(sfc))deallocate (dim_id,sfc,sfc1,dim) + if(allocated(sfc1) .and. allocated(sfc)) deallocate (sfc,sfc1) + if(allocated(dim)) deallocate (dim) if(allocated(sfc_fulldomain)) deallocate (sfc_fulldomain) endif ! mype @@ -2782,10 +2774,9 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & type (type_fv3regfilenameg),intent(in) ::fv3filenamegin integer(i_kind) ,intent(in ) :: iope real(r_kind),allocatable,dimension(:,:):: uu2d, uu2d_tmp - real(r_kind),allocatable,dimension(:):: wrk_send_2d real(r_kind),dimension(nlat,nlon,nsig):: hwork real(r_kind),dimension(nlat,nlon,nsig),intent(out),optional:: delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz - character(len=max_varname_length) :: varname,vgsiname + character(len=max_varname_length) :: varname character(len=max_varname_length) :: name character(len=max_varname_length), allocatable,dimension(:) :: varname_files @@ -3002,8 +2993,6 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i character(:), allocatable:: filenamein real(r_kind),allocatable,dimension(:,:):: u2d,v2d real(r_kind),allocatable,dimension(:,:):: uc2d,vc2d - character(len=max_varname_length) :: varname,vgsiname - real(r_kind),allocatable,dimension(:,:,:,:):: worksub integer(i_kind) u_grd_VarId,v_grd_VarId integer(i_kind) nlatcase,nloncase integer(i_kind) nxcase,nycase @@ -3300,6 +3289,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'q2m',ges_q2m,istatus); ier=ier+istatus call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'t2m',ges_t2m,istatus );ier=ier+istatus endif + if (ier/=0) call die('wrfv3_netcdf','cannot get pointers for fv3 met-fields, ier =',ier) if (laeroana_fv3cmaq) then call GSI_BundleGetPointer ( GSI_ChemGuess_Bundle(it), 'aalj',ges_aalj,istatus );ier=ier+istatus diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 8ccef7c38e..cf885c2b64 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -24,7 +24,7 @@ module gsimod use obsmod, only: doradaroneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& - rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_vrobs_raw,& + rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_vrobs_raw,if_use_w_vr,& minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,missing_to_nopcp,& ntilt_radarfiles,whichradar,& minobrangevr,maxtiltdbz,mintiltvr,mintiltdbz,l2rwthin,hurricane_radar @@ -99,7 +99,7 @@ module gsimod factv,factl,factp,factg,factw10m,facthowv,factcldch,niter,niter_no_qc,biascor,& init_jfunc,qoption,cwoption,switch_on_derivatives,tendsflag,jiterstart,jiterend,R_option,& bcoption,diurnalbc,print_diag_pcg,tsensible,diag_precon,step_start,pseudo_q2,& - clip_supersaturation,cnvw_option + clip_supersaturation,cnvw_option,hofx_2m_sfcfile use state_vectors, only: init_anasv,final_anasv use control_vectors, only: init_anacv,final_anacv,nrf,nvars,nrf_3d,cvars3d,cvars2d,& nrf_var,lcalc_gfdl_cfrac,incvars_to_zero,incvars_zero_strat,incvars_efold @@ -151,10 +151,10 @@ module gsimod readin_beta,use_localization_grid,use_gfs_ens,q_hyb_ens,i_en_perts_io, & l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, & ntotensgrp,nsclgrp,naensgrp,ngvarloc,ntlevs_ens,naensloc, & - i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,l_timloc_opt,& + r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,l_timloc_opt,& vdl_scale,vloc_varlist,& global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers - use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar + use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar use rapidrefresh_cldsurf_mod, only: init_rapidrefresh_cldsurf, & dfi_radar_latent_heat_time_period,metar_impact_radius,& metar_impact_radius_lowcloud,l_gsd_terrain_match_surftobs, & @@ -765,7 +765,7 @@ module gsimod oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& rmesh_vr,zmesh_dbz,zmesh_vr, ntilt_radarfiles, whichradar,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& - minobrangevr, maxtiltdbz, mintiltvr,mintiltdbz,if_vterminal,if_vrobs_raw,& + minobrangevr, maxtiltdbz, mintiltvr,mintiltdbz,if_vterminal,if_vrobs_raw,if_use_w_vr,& if_model_dbz,imp_physics,lupp,netcdf_diag,binary_diag,l_wcp_cwm,aircraft_recon,diag_version,& write_fv3_incr,incvars_to_zero,incvars_zero_strat,incvars_efold,diag_version,& cao_check,lcalc_gfdl_cfrac,tau_fcst,efsoi_order,lupdqc,lqcoef,cnvw_option,l2rwthin,hurricane_radar,& @@ -1047,7 +1047,7 @@ module gsimod ! l_foreaft_thin - separate TDR fore/aft scan for thinning namelist/obs_input/dmesh,time_window_max,time_window_rad, & - ext_sonde,l_foreaft_thin + ext_sonde,l_foreaft_thin,hofx_2m_sfcfile ! SINGLEOB_TEST (one observation test case setup): ! maginnov - magnitude of innovation for one ob @@ -1368,23 +1368,28 @@ module gsimod ! l_timloc_opt - if true, then turn on time-dependent localization ! ngvarloc - number of variable-dependent localization lengths ! naensloc - total number of spatial localization lengths and scale separation lengths (should be naensgrp+nsclgrp-1) -! i_ensloccov4tim - flag of cross-temporal localization -! =0: cross-temporal covariance is retained -! =1: cross-temporal covariance is zero -! i_ensloccov4var - flag of cross-variable localization -! =0: cross-variable covariance is retained -! =1: cross-variable covariance is zero -! i_ensloccov4scl - flag of cross-scale localization -! =0: cross-scale covariance is retained -! =1: cross-scale covariance is zero -! +! r_ensloccov4tim - factor multiplying to cross-time covariance +! For example, +! =0.0: cross-time covariance is decreased to zero +! =0.5: cross-time covariance is decreased to half +! =1.0: cross-time covariance is retained +! r_ensloccov4var - factor multiplying to cross-variable covariance +! For example, +! =0.0: cross-variable covariance is decreased to zero +! =0.5: cross-variable covariance is decreased to half +! =1.0: cross-variable covariance is retained +! r_ensloccov4scl - factor multiplying to cross-scale covariance +! For example, +! =0.0: cross-scale covariance is decreased to zero +! =0.5: cross-scale covariance is decreased to half +! =1.0: cross-scale covariance is retained ! global_spectral_filter_sd - if true, use spectral filter function for ! scale decomposition in the global application (Huang et al. 2021) ! assign_vdl_nml - if true, vdl_scale, and vloc_varlist will be used for ! assigning variable-dependent localization upon SDL in gsiparm.anl. ! This method described in (Wang and Wang 2022, JAMES) is ! equivalent to, but different from the method associated -! with the parameter i_ensloccov4var. +! with the parameter r_ensloccov4var. ! vloc_varlist - list of control variables using the same localization length, ! effective only with assign_vdl_nml=.true. For example, ! vloc_varlist(1,:) = 'sf','vp','ps','t', @@ -1408,13 +1413,14 @@ module gsimod ! s_ens_h = v1L1 v2L1 v3L1 v1L2 v2L2 ! Then localization lengths will be assigned as above. ! - namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,& + namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,& + l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,& pseudo_hybens,merge_two_grid_ensperts,regional_ensemble_option,fv3sar_bg_opt,fv3sar_ensemble_opt,full_ensemble,pwgtflg,& jcap_ens_test,beta_s0,beta_e0,s_ens_h,s_ens_v,readin_localization,eqspace_ensgrid,readin_beta,& grid_ratio_ens, & oz_univ_static,write_ens_sprd,use_localization_grid,use_gfs_ens, & i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, & - nsclgrp,l_timloc_opt,ngvarloc,naensloc,i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,& + nsclgrp,l_timloc_opt,ngvarloc,naensloc,r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,& vdl_scale,vloc_varlist,& global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers @@ -1819,9 +1825,10 @@ subroutine gsimain_initialize n_ens_gfs=n_ens n_ens_fv3sar=0 else - write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5' + if(mype == 0)write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5' endif - + weight_ens_gfs=one + weight_ens_fv3sar=one endif if(ltlint) then if(vqc .or. njqc .or. nvqc)then @@ -2038,15 +2045,17 @@ subroutine gsimain_initialize baldiag_inc =.false. end if -! If reflectivity is intended to be assimilated, beta_s0 should be zero. +! Warning of reflectivity assimilation with static B if ( beta_s0 > 0.0_r_kind )then ! skipped in case of direct reflectivity DA because it works in Envar and hybrid if ( l_use_rw_columntilt .or. l_use_dbz_directDA) then do i=1,ndat if ( if_model_dbz .and. (index(dtype(i), 'dbz') /= 0) )then - write(6,*)'beta_s0 needs to be set to zero in this GSI version, when reflectivity is directly assimilated. & - Static B extended for radar reflectivity assimilation will be included in future version.' - call stop2(8888) + if (mype==0) then + write(6,*)'GSIMOD: ***WARNING*** static B for reflectivity is regarded as zero in this GSI version & + even though beta_s0 =',beta_s0 + write(6,*)'Static B extended for radar reflectivity assimilation will be included in future version.' + end if end if end do end if diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 7e74b3ec27..fe2e058dff 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -3592,7 +3592,7 @@ subroutine bkerror_a_en(grady) !$$$ end documentation block use kinds, only: r_kind,i_kind use constants, only: zero - use gsi_4dvar, only: nsubwin, lsqrtb + use gsi_4dvar, only: nsubwin use control_vectors, only: control_vector use timermod, only: timer_ini,timer_fnl use hybrid_ensemble_parameters, only: n_ens @@ -3610,11 +3610,6 @@ subroutine bkerror_a_en(grady) real(r_kind),allocatable,dimension(:,:) :: z real(r_kind),allocatable,dimension(:) :: ztmp - if (lsqrtb) then - write(6,*)'bkerror_a_en: not for use with lsqrtb' - call stop2(317) - end if - ! Initialize timer call timer_ini('bkerror_a_en') @@ -3629,6 +3624,7 @@ subroutine bkerror_a_en(grady) call sqrt_beta_e_mult(grady) ! Apply variances, as well as vertical & horizontal parts of background error +! !$omp parallel do schedule(dynamic,1) private(ii) do ii=1,nsubwin if (naensgrp==1) then call bkgcov_a_en_new_factorization(1,grady%aens(ii,1,1:n_ens)) @@ -3710,12 +3706,10 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) type(gsi_bundle),intent(inout) :: a_en(n_ens) ! Local Variables - integer(i_kind) ii,k,iflg,iadvance,iback,is,ie,ipnt,istatus + integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus real(r_kind) hwork(grd_loc%inner_vars,grd_loc%nlat,grd_loc%nlon,grd_loc%kbegin_loc:grd_loc%kend_alloc) real(r_kind),allocatable,dimension(:):: a_en_work - iflg=1 - call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus) if(istatus/=0) then write(6,*)'bkgcov_a_en_new_factorization: trouble getting pointer to ensemble CV' @@ -5553,7 +5547,7 @@ subroutine setup_ensgrp2aensgrp ! !$$$ end documentation block use constants, only: zero,one - use hybrid_ensemble_parameters, only: l_timloc_opt,i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl + use hybrid_ensemble_parameters, only: l_timloc_opt,r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl use hybrid_ensemble_parameters, only: ensloccov4tim,ensloccov4var,ensloccov4scl use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,ntlevs_ens,nsclgrp,ngvarloc use hybrid_ensemble_parameters, only: ensgrp2aensgrp @@ -5596,33 +5590,12 @@ subroutine setup_ensgrp2aensgrp enddo enddo - if (i_ensloccov4tim==0) then - ensloccov4tim=one - elseif (i_ensloccov4tim==1)then - ensloccov4tim=zero - ensloccov4tim(1)=one - else - write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4tim' - call stop2(666) - endif - if (i_ensloccov4var==0) then - ensloccov4var=one - elseif (i_ensloccov4var==1)then - ensloccov4var=zero - ensloccov4var(1)=one - else - write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4var' - call stop2(666) - endif - if (i_ensloccov4scl==0) then - ensloccov4scl=one - elseif (i_ensloccov4scl==1)then - ensloccov4scl=zero - ensloccov4scl(1)=one - else - write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4scl' - call stop2(666) - endif + ensloccov4tim=r_ensloccov4tim + ensloccov4tim(1)=one + ensloccov4var=r_ensloccov4var + ensloccov4var(1)=one + ensloccov4scl=r_ensloccov4scl + ensloccov4scl(1)=one do itim2=1,ntimloc do itim1=1,ntimloc diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 index 17416f68fb..342dead615 100644 --- a/src/gsi/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -134,15 +134,21 @@ module hybrid_ensemble_parameters ! l_timloc_opt: if true, then turn on time-dependent localization ! ngvarloc: number of variable-dependent localization lengths ! naensloc: total number of spatial localization lengths and scale separation lengths (should be naensgrp+nsclgrp-1) -! i_ensloccov4tim: flag of cross-temporal localization -! =0: cross-temporal covariance is retained -! =1: cross-temporal covariance is zero -! i_ensloccov4var: flag of cross-variable localization -! =0: cross-variable covariance is retained -! =1: cross-variable covariance is zero -! i_ensloccov4scl: flag of cross-scale localization -! =0: cross-scale covariance is retained -! =1: cross-scale covariance is zero +! r_ensloccov4tim: factor multiplying to cross-time covariance +! For example, +! =0.0: cross-time covariance is decreased to zero +! =0.5: cross-time covariance is decreased to half +! =1.0: cross-time covariance is retained +! r_ensloccov4var: factor multiplying to cross-variable covariance +! For example, +! =0.0: cross-variable covariance is decreased to zero +! =0.5: cross-variable covariance is decreased to half +! =1.0: cross-variable covariance is retained +! r_ensloccov4scl: factor multiplying to cross-scale covariance +! For example, +! =0.0: cross-scale covariance is decreased to zero +! =0.5: cross-scale covariance is decreased to half +! =1.0: cross-scale covariance is retained !===================================================================================================== ! ! @@ -287,6 +293,7 @@ module hybrid_ensemble_parameters public :: generate_ens,n_ens,nlon_ens,nlat_ens,jcap_ens,jcap_ens_test,l_hyb_ens,& s_ens_h,oz_univ_static,vvlocal public :: n_ens_gfs,n_ens_fv3sar + public :: weight_ens_gfs,weight_ens_fv3sar public :: uv_hyb_ens,q_hyb_ens,s_ens_v,beta_s0,beta_e0,aniso_a_en,s_ens_hv,s_ens_vv public :: readin_beta,beta_s,beta_e public :: readin_localization @@ -325,7 +332,7 @@ module hybrid_ensemble_parameters public :: ensloccov4tim,ensloccov4var,ensloccov4scl public :: alphacvarsclgrpmat public :: l_timloc_opt - public :: i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl + public :: r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl public :: idaen3d,idaen2d public :: ens_fast_read public :: parallelization_over_ensmembers @@ -361,6 +368,7 @@ module hybrid_ensemble_parameters integer(i_kind) i_en_perts_io integer(i_kind) n_ens,nlon_ens,nlat_ens,jcap_ens,jcap_ens_test integer(i_kind) n_ens_gfs,n_ens_fv3sar + real(r_kind) weight_ens_gfs,weight_ens_fv3sar real(r_kind) beta_s0,beta_e0,grid_ratio_ens integer(i_kind),parameter::max_naensloc=20 integer(i_kind),parameter::max_nvars=100 @@ -393,9 +401,9 @@ module hybrid_ensemble_parameters integer(i_kind) :: ntotensgrp=1 integer(i_kind) :: naensloc=1 integer(i_kind) :: ngvarloc=1 - integer(i_kind) :: i_ensloccov4tim=0 - integer(i_kind) :: i_ensloccov4var=0 - integer(i_kind) :: i_ensloccov4scl=0 + real(r_kind) :: r_ensloccov4tim + real(r_kind) :: r_ensloccov4var + real(r_kind) :: r_ensloccov4scl integer(i_kind),allocatable,dimension(:) :: idaen3d,idaen2d real(r_kind),allocatable,dimension(:,:) :: spc_multwgt @@ -497,6 +505,11 @@ subroutine init_hybrid_ensemble_parameters l_both_fv3sar_gfs_ens=.false. n_ens_gfs=0 n_ens_fv3sar=0 + weight_ens_gfs=one + weight_ens_fv3sar=one + r_ensloccov4tim=one + r_ensloccov4var=one + r_ensloccov4scl=one vdl_scale = 0 vloc_varlist = 'aaa' global_spectral_filter_sd=.false. diff --git a/src/gsi/intall.f90 b/src/gsi/intall.f90 index 0f8faa89f8..d10eb1e7e5 100644 --- a/src/gsi/intall.f90 +++ b/src/gsi/intall.f90 @@ -184,13 +184,13 @@ subroutine intall(sval,sbias,rval,rbias) use intjomod, only: intjo use bias_predictors, only : predictors,assignment(=) use state_vectors, only: allocate_state,deallocate_state + use state_vectors, only: qgpresent,qspresent,qrpresent,qipresent,qlpresent + use state_vectors, only: cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent use intjcmod, only: intlimq,intlimg,intlimv,intlimp,intlimw10m,intlimhowv,intlimcldch,& intliml,intjcpdry1,intjcpdry2,intjcdfi,intlimqc use timermod, only: timer_ini,timer_fnl use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) - use state_vectors, only: svars2d, svars3d - use mpeu_util, only: getindex use guess_grids, only: ntguessig,nfldsig use mpl_allreducemod, only: mpl_allreduce @@ -238,11 +238,11 @@ subroutine intall(sval,sbias,rval,rbias) end if if (ljclimqc) then if (.not.ljc4tlevs) then - if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql') - if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi') - if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr') - if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs') - if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg') + if (qlpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql') + if (qipresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi') + if (qrpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr') + if (qspresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs') + if (qgpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg') else do ibin=1,nobs_bins if (nobs_bins /= nfldsig) then @@ -250,34 +250,34 @@ subroutine intall(sval,sbias,rval,rbias) else it=ibin end if - if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin),sval(ibin),it,'ql') - if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin),sval(ibin),it,'qi') - if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin),sval(ibin),it,'qr') - if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin),sval(ibin),it,'qs') - if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin),sval(ibin),it,'qg') + if (qlpresent) call intlimqc(rval(ibin),sval(ibin),it,'ql') + if (qipresent) call intlimqc(rval(ibin),sval(ibin),it,'qi') + if (qrpresent) call intlimqc(rval(ibin),sval(ibin),it,'qr') + if (qspresent) call intlimqc(rval(ibin),sval(ibin),it,'qs') + if (qgpresent) call intlimqc(rval(ibin),sval(ibin),it,'qg') end do end if end if ! ljclimqc ! RHS for gust constraint - if (getindex(svars2d,'gust')>0)call intlimg(rval(1),sval(1)) + if (gustpresent)call intlimg(rval(1),sval(1)) ! RHS for vis constraint - if (getindex(svars2d,'vis')>0) call intlimv(rval(1),sval(1)) + if (vispresent) call intlimv(rval(1),sval(1)) ! RHS for pblh constraint - if (getindex(svars2d,'pblh')>0) call intlimp(rval(1),sval(1)) + if (pblhpresent) call intlimp(rval(1),sval(1)) ! RHS for wspd10m constraint - if (getindex(svars2d,'wspd10m')>0) call intlimw10m(rval(1),sval(1)) + if (wspd10mpresent) call intlimw10m(rval(1),sval(1)) ! RHS for howv constraint - if (getindex(svars2d,'howv')>0) call intlimhowv(rval(1),sval(1)) + if (howvpresent) call intlimhowv(rval(1),sval(1)) ! RHS for lcbas constraint - if (getindex(svars2d,'lcbas')>0) call intliml(rval(1),sval(1)) + if (lcbaspresent) call intliml(rval(1),sval(1)) ! RHS for cldch constraint - if (getindex(svars2d,'cldch')>0) call intlimcldch(rval(1),sval(1)) + if (cldchpresent) call intlimcldch(rval(1),sval(1)) end if @@ -296,7 +296,7 @@ subroutine intall(sval,sbias,rval,rbias) end if -! Take care of background error for bias correction terms +! Sum over all processors for bias correction terms call mpl_allreduce(nrclen,qpvals=qpred) @@ -313,6 +313,7 @@ subroutine intall(sval,sbias,rval,rbias) ! RHS for Jc DFI if (ljcdfi .and. nobs_bins>1) call intjcdfi(rval,sval) +! Put bias correction terms in correct location if(nsclen > 0)then do i=1,nsclen rbias%predr(i)=qpred(i) diff --git a/src/gsi/intgps.f90 b/src/gsi/intgps.f90 index bc78db085e..16ead93d1c 100644 --- a/src/gsi/intgps.f90 +++ b/src/gsi/intgps.f90 @@ -118,6 +118,7 @@ subroutine intgps_(gpshead,rval,sval) real(r_kind) :: w1,w2,w3,w4 real(r_kind) :: p_TL,p_AD,t_TL,t_AD,q_TL,q_AD real(r_kind) :: val,pg_gps + real(r_kind),dimension(nsig) :: valk real(r_kind) ::cg_gps,grad,p0,wnotgross,wgross real(r_kind),pointer,dimension(:) :: st,sq real(r_kind),pointer,dimension(:) :: rt,rq @@ -154,16 +155,19 @@ subroutine intgps_(gpshead,rval,sval) w3=gpsptr%wij(3) w4=gpsptr%wij(4) - - val=zero - ! local refractivity (linear operator) +!$omp parallel do schedule(dynamic,1) private(j,t_TL,q_TL,p_TL) + do j=1,nsig + t_TL=w1*st(i1(j))+w2*st(i2(j))+w3*st(i3(j))+w4*st(i4(j)) + q_TL=w1*sq(i1(j))+w2*sq(i2(j))+w3*sq(i3(j))+w4*sq(i4(j)) + p_TL=w1*sp(i1(j))+w2*sp(i2(j))+w3*sp(i3(j))+w4*sp(i4(j)) + valk(j) = p_TL*gpsptr%jac_p(j) + t_TL*gpsptr%jac_t(j)+q_TL*gpsptr%jac_q(j) + end do + + val=zero do j=1,nsig - t_TL=w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j)) - q_TL=w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j)) - p_TL=w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j)) - val = val + p_TL*gpsptr%jac_p(j) + t_TL*gpsptr%jac_t(j)+q_TL*gpsptr%jac_q(j) + val = val+valk(j) end do if (luse_obsdiag)then @@ -204,6 +208,7 @@ subroutine intgps_(gpshead,rval,sval) ! adjoint +!$omp parallel do schedule(dynamic,1) private(j,t_AD,q_AD,p_AD) do j=1,nsig t_AD = grad*gpsptr%jac_t(j) rt(i1(j))=rt(i1(j))+w1*t_AD diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90 index c0c23151ee..2b093312ac 100644 --- a/src/gsi/intjcmod.f90 +++ b/src/gsi/intjcmod.f90 @@ -740,7 +740,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc) it=ntguessig mass=zero_quad - rcon=one_quad/(two_quad*float(nlon)) + rcon=(one_quad/(two_quad*float(nlon)))**2 mm1=mype+1 do n=1,nbins @@ -805,8 +805,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc) ! Remove water-vapor contribution to get incremental dry ps ! if (mype==0) write(6,*)'intjcpdry: total mass =', mass(n) ! if (mype==0) write(6,*)'intjcpdry: wv mass =', mass(nbins+n) - dmass=mass(n)-mass(nbins+n) - dmass=bamp_jcpdry*dmass*rcon*rcon + dmass=bamp_jcpdry*(mass(n)-mass(nbins+n))*rcon if(present(pjc)) then pjc = dmass*dmass endif @@ -872,7 +871,7 @@ subroutine intjcpdry1(sval,nbins,mass) ! !$$$ use mpimod, only: mype - use gridmod, only: lat2,lon2,nsig,wgtlats,nlon,istart + use gridmod, only: lat2,lon2,nsig,wgtlats,istart use guess_grids, only: ges_prsi,ntguessig use gsi_metguess_mod, only: gsi_metguess_get implicit none @@ -884,7 +883,7 @@ subroutine intjcpdry1(sval,nbins,mass) ! Declare local variables real(r_quad),dimension(nsig) :: mass2 - real(r_quad) rcon,con + real(r_quad) con integer(i_kind) i,j,k,it,ii,mm1,icw,iql,iqi integer(i_kind) iq,iqr,iqs,iqg,iqh,ips real(r_kind),pointer,dimension(:,:,:) :: sq =>NULL() @@ -901,13 +900,11 @@ subroutine intjcpdry1(sval,nbins,mass) it=ntguessig mass=zero_quad - rcon=one_quad/(two_quad*float(nlon)) mm1=mype+1 do n=1,nbins ! Retrieve pointers ! Simply return if any pointer not found - iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0 call gsi_bundlegetpointer(sval(n),'q' ,sq, iq ) call gsi_bundlegetpointer(sval(n),'cw',sc, icw ) call gsi_bundlegetpointer(sval(n),'ql',sql, iql ) @@ -1023,11 +1020,10 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) integer(i_kind) :: n it=ntguessig - rcon=one_quad/(two_quad*float(nlon)) + rcon=(one_quad/(two_quad*float(nlon)))**2 mm1=mype+1 do n=1,nbins - iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0 call gsi_bundlegetpointer(rval(n),'q' ,rq, iq ) call gsi_bundlegetpointer(rval(n),'cw',rc, icw ) call gsi_bundlegetpointer(rval(n),'ql',rql, iql ) @@ -1037,7 +1033,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) call gsi_bundlegetpointer(rval(n),'qg',rqg, iqg ) call gsi_bundlegetpointer(rval(n),'qh',rqh, iqh ) call gsi_bundlegetpointer(rval(n),'ps',rp, ips ) - if( iq*ips /=0 .or. icw*(iql+iqi) /=0 ) then + if( ips /= 0 .or. iq /=0 .or. icw*(iql+iqi) /=0 ) then if (mype==0) write(6,*)'intjcpdry2: warning - missing some required variables' if (mype==0) write(6,*)'intjcpdry2: constraint for dry mass constraint not performed' return @@ -1045,8 +1041,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) ! Remove water-vapor contribution to get incremental dry ps ! if (mype==0) write(6,*)'intjcpdry: total mass =', mass(n) ! if (mype==0) write(6,*)'intjcpdry: wv mass =', mass(nbins+n) - dmass=mass(n)-mass(nbins+n) - dmass=bamp_jcpdry*dmass*rcon*rcon + dmass=bamp_jcpdry*(mass(n)-mass(nbins+n))*rcon if(present(pjc)) then pjc = dmass*dmass endif diff --git a/src/gsi/intjo.f90 b/src/gsi/intjo.f90 index e514a38a22..91b811147e 100644 --- a/src/gsi/intjo.f90 +++ b/src/gsi/intjo.f90 @@ -240,8 +240,6 @@ subroutine intjo_(rval,qpred,sval,sbias) use m_obsdiags, only: obOper_destroy use gsi_obOper, only: obOper -use intradmod, only: setrad - implicit none ! Declare passed variables @@ -257,7 +255,6 @@ subroutine intjo_(rval,qpred,sval,sbias) class(obOper),pointer:: it_obOper !****************************************************************************** - call setrad(sval(1)) ! "RHS for jo", as it was labeled in intall(). !$omp parallel do schedule(dynamic,1) private(ibin,it,ix,it_obOper) diff --git a/src/gsi/intrad.f90 b/src/gsi/intrad.f90 index 689b6c821e..19bb400034 100644 --- a/src/gsi/intrad.f90 +++ b/src/gsi/intrad.f90 @@ -83,13 +83,14 @@ subroutine setrad(sval) use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_metguess_mod, only: gsi_metguess_get use mpeu_util, only: getindex + use mpimod, only: mype implicit none ! Declare passed variables type(gsi_bundle), intent(in ) :: sval ! Declare local variables - integer(i_kind) ier,istatus,indx + integer(i_kind) indx logical look real(r_kind),pointer,dimension(:) :: st,sq,scw,soz,su,sv,sqg,sqh,sqi,sql,sqr,sqs @@ -97,91 +98,110 @@ subroutine setrad(sval) if(done_setting) return -! Retrieve pointers; return when not found (except in case of non-essentials) - ier=0; itsen=0; iqv=0; ius=0; ivs=0; isst=0; ioz=0; icw=0 - iqg=0; iqh=0; iqi=0; iql=0; iqr=0; iqs=0 - call gsi_bundlegetpointer(sval,'u', su, istatus);ius=istatus+ius - call gsi_bundlegetpointer(sval,'v', sv, istatus);ivs=istatus+ivs - call gsi_bundlegetpointer(sval,'tsen' ,st, istatus);itsen=istatus+itsen - call gsi_bundlegetpointer(sval,'q', sq, istatus);iqv=istatus+iqv - call gsi_bundlegetpointer(sval,'cw' ,scw,istatus);icw=istatus+icw - call gsi_bundlegetpointer(sval,'oz' ,soz,istatus);ioz=istatus+ioz - call gsi_bundlegetpointer(sval,'sst',sst,istatus);isst=istatus+isst - call gsi_bundlegetpointer(sval,'qg' ,sqg,istatus);iqg=istatus+iqg - call gsi_bundlegetpointer(sval,'qh' ,sqh,istatus);iqh=istatus+iqh - call gsi_bundlegetpointer(sval,'qi' ,sqi,istatus);iqi=istatus+iqi - call gsi_bundlegetpointer(sval,'ql' ,sql,istatus);iql=istatus+iql - call gsi_bundlegetpointer(sval,'qr' ,sqr,istatus);iqr=istatus+iqr - call gsi_bundlegetpointer(sval,'qs' ,sqs,istatus);iqs=istatus+iqs - lgoback=(ius/=0).and.(ivs/=0).and.(itsen/=0).and.(iqv/=0).and.(ioz/=0).and.(icw/=0).and.(isst/=0) - lgoback=lgoback .and.(iqg/=0).and.(iqh/=0).and.(iqi/=0).and.(iql/=0).and.(iqr/=0).and.(iqs/=0) - if(lgoback)return - ! check to see if variable participates in forward operator ! tsen indx=getindex(radjacnames,'tsen') - look=(itsen==0.and.indx>0) itsen=-1 - if(look) itsen=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'tsen',st, itsen) + look=itsen==0 + if(look) itsen=radjacindxs(indx) + end if ! q indx=getindex(radjacnames,'q') - look=(iqv==0.and.indx>0) iqv=-1 - if(look) iqv=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'q', sq, iqv) + look=iqv==0 + if(look) iqv=radjacindxs(indx) + end if ! oz indx=getindex(radjacnames,'oz') - look=(ioz ==0.and.indx>0) ioz=-1 - if(look) ioz =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'oz' , soz,ioz) + look=ioz ==0 + if(look) ioz =radjacindxs(indx) + end if ! cw indx=getindex(radjacnames,'cw') - look=(icw ==0.and.indx>0) icw=-1 - if(look) icw =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'cw' , scw,icw) + look=icw ==0 + if(look) icw =radjacindxs(indx) + end if ! sst indx=getindex(radjacnames,'sst') - look=(isst==0.and.indx>0) isst=-1 - if(look) isst=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'sst', sst,isst) + look=isst==0 + if(look) isst=radjacindxs(indx) + end if ! us & vs indx=getindex(radjacnames,'u') - look=(ius==0.and.indx>0) ius=-1 - if(look) ius=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'u', su, ius) + look=ius==0 + if(look) ius=radjacindxs(indx) + end if indx=getindex(radjacnames,'v') - look=(ivs==0.and.indx>0) ivs=-1 - if(look) ivs=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'v', sv, ivs) + look=ivs==0 + if(look) ivs=radjacindxs(indx) + end if ! qg indx=getindex(radjacnames,'qg') - look=(iqg ==0.and.indx>0) iqg=-1 - if(look) iqg =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qg' , sqg,iqg) + look=iqg ==0 + if(look) iqg =radjacindxs(indx) + end if ! qh indx=getindex(radjacnames,'qh') - look=(iqh ==0.and.indx>0) iqh=-1 - if(look) iqh =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qh' , sqh,iqh) + look=iqh ==0 + if(look) iqh =radjacindxs(indx) + end if ! qi indx=getindex(radjacnames,'qi') - look=(iqi ==0.and.indx>0) iqi=-1 - if(look) iqi =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qi' , sqi,iqi) + look=iqi ==0 + if(look) iqi =radjacindxs(indx) + end if ! ql indx=getindex(radjacnames,'ql') - look=(iql ==0.and.indx>0) iql=-1 - if(look) iql =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'ql' , sql,iql) + look=iql ==0 + if(look) iql =radjacindxs(indx) + end if ! qr indx=getindex(radjacnames,'qr') - look=(iqr ==0.and.indx>0) iqr=-1 - if(look) iqr =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qr' , sqr,iqr) + look=iqr ==0 + if(look) iqr =radjacindxs(indx) + end if ! qs indx=getindex(radjacnames,'qs') - look=(iqs ==0.and.indx>0) iqs=-1 - if(look) iqs =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qs' , sqs,iqs) + look=iqs ==0 + if(look) iqs =radjacindxs(indx) + end if luseu=ius>=0 lusev=ivs>=0 @@ -196,6 +216,26 @@ subroutine setrad(sval) luseqr=iqr>=0 luseqs=iqs>=0 lusesst=isst>=0 + lgoback=.not.(luseu .or. lusev .or. luset .or. luseq .or. luseoz .or. lusecw .or. & + luseql .or. luseqi .or. luseqh .or. luseqg .or. luseqr .or. luseqs .or. & + lusesst) + + if(mype == 0)then + write(6,*) ' following variables are used in int and stp radiance calculations ' + if(luset) write(6,*)'tsen' + if(luseq) write(6,*)'q' + if(luseoz)write(6,*)'oz' + if(luseu) write(6,*)'u' + if(lusev) write(6,*)'v' + if(lusesst) write(6,*)'sst' + if(lusecw) write(6,*)'cw' + if(luseql) write(6,*)'ql' + if(luseqi) write(6,*)'qi' + if(luseqh) write(6,*)'qh' + if(luseqg) write(6,*)'qg' + if(luseqr) write(6,*)'qr' + if(luseqs) write(6,*)'qs' + end if done_setting = .true. @@ -308,7 +348,7 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) ! Declare local variables integer(i_kind) i1,i2,i3,i4,n,k,ic,ix,nn,mm,ncr1,ncr2 - integer(i_kind) ier,istatus + integer(i_kind) istatus integer(i_kind),dimension(nsig) :: i1n,i2n,i3n,i4n real(r_kind),allocatable,dimension(:):: val real(r_kind) w1,w2,w3,w4 @@ -331,7 +371,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) call timer_ini('intrad') ! Retrieve pointers; return when not found (except in case of non-essentials) - ier=0 if(luseu)then call gsi_bundlegetpointer(sval,'u', su, istatus) call gsi_bundlegetpointer(rval,'u', ru, istatus) @@ -468,7 +507,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) end do - ! For all other configurations ! begin channel specific calculations allocate(val(radptr%nchan)) @@ -487,10 +525,8 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) end do end if -!$omp parallel do schedule(dynamic,1) private(nn,ic,ix,k) +!$omp parallel do schedule(dynamic,1) private(nn,k,ncr1) do nn=1,radptr%nchan - ic=radptr%icx(nn) - ix=(ic-1)*npred ! include observation increment and lapse rate contributions to bias correction val(nn)=zero @@ -499,25 +535,24 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) do k=1,nsigradjac val(nn)=val(nn)+tdir(k)*radptr%dtb_dvar(k,nn) end do - end do - ncr1=0 ! Include contributions from remaining bias correction terms - do nn=1,radptr%nchan if( .not. ladtest_obs) then if(radptr%use_corr_obs)then val_quad = zero_quad do mm=1,nn - ncr1=ncr1+1 + ncr1=radptr%iccerr(nn)+mm val_quad=val_quad+radptr%rsqrtinv(ncr1)*biasvect(mm) enddo val(nn)=val(nn) + val_quad else - val(nn)=val(nn)+biasvect(nn) + val(nn)=val(nn) + biasvect(nn) endif end if + end do - if(luse_obsdiag)then + if(luse_obsdiag)then + do nn=1,radptr%nchan if (lsaveobsens) then val(nn)=val(nn)*radptr%err2(nn)*radptr%raterr2(nn) !-- radptr%diags(nn)%ptr%obssen(jiter) = val(nn) @@ -526,13 +561,14 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) !-- if (radptr%luse) radptr%diags(nn)%ptr%tldepart(jiter) = val(nn) if (radptr%luse) call obsdiagNode_set(radptr%diags(nn)%ptr,jiter=jiter,tldepart=val(nn)) endif - endif - end do + end do + end if if (l_do_adjoint) then - do nn=1,radptr%nchan - ic=radptr%icx(nn) - if (.not. lsaveobsens) then + if (.not. lsaveobsens) then +!$omp parallel do schedule(dynamic,1) private(nn,ic,cg_rad,wnotgross,wgross,p0) + do nn=1,radptr%nchan + ic=radptr%icx(nn) if( .not. ladtest_obs) val(nn)=val(nn)-radptr%res(nn) ! Multiply by variance. @@ -546,51 +582,45 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) endif if(.not.ladtest_obs) val(nn) = val(nn)*radptr%err2(nn)*radptr%raterr2(nn) - endif - enddo + enddo + endif ! Extract contributions from bias correction terms -! use compensated summation if( .not. ladtest_obs) then - if (radptr%use_corr_obs) then - ncr1 = 0 - do mm=1,radptr%nchan - ncr1 = ncr1 + mm - ncr2 = ncr1 - biasvect(mm) = zero - do nn=mm,radptr%nchan - biasvect(mm)=biasvect(mm)+radptr%rsqrtinv(ncr2)*val(nn) - ncr2 = ncr2 + nn - enddo - end do - endif + if(radptr%luse)then + if (radptr%use_corr_obs) then +!$omp parallel do schedule(dynamic,1) private(n,nn,ix,ncr1,ncr2,mm) + do nn=1,radptr%nchan + ncr1 = radptr%iccerr(nn)+nn + ncr2 = ncr1 + biasvect(nn) = zero + do mm=nn,radptr%nchan + biasvect(nn)=biasvect(nn)+radptr%rsqrtinv(ncr2)*val(mm) + ncr2 = ncr2 + mm + enddo - if(radptr%luse)then - if(radptr%use_corr_obs)then - do nn=1,radptr%nchan - ix=(radptr%icx(nn)-1)*npred - do n=1,npred - rpred(ix+n)=rpred(ix+n)+biasvect(nn)*radptr%pred(n,nn) - enddo + ix=(radptr%icx(nn)-1)*npred + do n=1,npred + rpred(ix+n)=rpred(ix+n)+biasvect(nn)*radptr%pred(n,nn) enddo - else - do nn=1,radptr%nchan - ix=(radptr%icx(nn)-1)*npred - do n=1,npred - rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn) - end do - end do - end if - end if + enddo + else +!$omp parallel do schedule(dynamic,1) private(n,nn,ix) + do nn=1,radptr%nchan + ix=(radptr%icx(nn)-1)*npred + do n=1,npred + rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn) + end do + end do + end if + end if - deallocate(biasvect) + deallocate(biasvect) end if ! not ladtest_obs - endif ! Begin adjoint - if (l_do_adjoint) then !$omp parallel do schedule(dynamic,1) private(k,nn) do k=1,nsigradjac tval(k)=zero diff --git a/src/gsi/intrw.f90 b/src/gsi/intrw.f90 index df3ec162a9..bac4448c0d 100644 --- a/src/gsi/intrw.f90 +++ b/src/gsi/intrw.f90 @@ -96,7 +96,7 @@ subroutine intrw_(rwhead,rval,sval) !$$$ use kinds, only: r_kind,i_kind use constants, only: half,one,tiny_r_kind,cg_term,r3600 - use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag + use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag,if_use_w_vr use qcmod, only: nlnqc_iter,varqc_iter use jfunc, only: jiter use gsi_bundlemod, only: gsi_bundle @@ -128,7 +128,7 @@ subroutine intrw_(rwhead,rval,sval) call gsi_bundlegetpointer(sval,'u',su,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'v',sv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'w',sw,istatus) - if (istatus==0) then + if (if_use_w_vr.and.istatus==0) then include_w=.true. else include_w=.false. @@ -136,7 +136,7 @@ subroutine intrw_(rwhead,rval,sval) call gsi_bundlegetpointer(rval,'u',ru,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'v',rv,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'w',rw,istatus) - if (istatus==0) then + if (if_use_w_vr.and.istatus==0) then include_w=.true. else include_w=.false. diff --git a/src/gsi/intsst.f90 b/src/gsi/intsst.f90 index d910247526..6b255d0d02 100644 --- a/src/gsi/intsst.f90 +++ b/src/gsi/intsst.f90 @@ -79,7 +79,7 @@ subroutine intsst(ssthead,rval,sval) ! !$$$ use kinds, only: r_kind,i_kind - use constants, only: half,one,tiny_r_kind,cg_term + use constants, only: zero,half,one,tiny_r_kind,cg_term use obsmod, only: lsaveobsens, l_do_adjoint,luse_obsdiag use qcmod, only: nlnqc_iter,varqc_iter use gsi_nstcouplermod, only: nst_gsi @@ -100,7 +100,6 @@ subroutine intsst(ssthead,rval,sval) ! real(r_kind) penalty real(r_kind) w1,w2,w3,w4 real(r_kind) val - real(r_kind) tval,tdir real(r_kind) cg_sst,p0,grad,wnotgross,wgross,pg_sst real(r_kind),pointer,dimension(:) :: ssst real(r_kind),pointer,dimension(:) :: rsst @@ -108,15 +107,14 @@ subroutine intsst(ssthead,rval,sval) ! If no sst data return if(.not. associated(ssthead))return + if(.not. nst_gsi > 2) return ! Retrieve pointers ! Simply return if any pointer not found - ier=0 - call gsi_bundlegetpointer(sval,'sst',ssst,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'sst',ssst,istatus);ier=istatus call gsi_bundlegetpointer(rval,'sst',rsst,istatus);ier=istatus+ier if(ier/=0)return - !sstptr => ssthead sstptr => sstNode_typecast(ssthead) do while (associated(sstptr)) j1=sstptr%ij(1) @@ -129,15 +127,9 @@ subroutine intsst(ssthead,rval,sval) w4=sstptr%wij(4) ! Forward model - val=w1*ssst(j1)+w2*ssst(j2)& - +w3*ssst(j3)+w4*ssst(j4) - - if ( nst_gsi > 2 ) then - tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward - val = tdir*sstptr%tz_tr ! Include contributions from Tz jacobian - else - val = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward - endif + val=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) + + val = val*sstptr%tz_tr ! Include contributions from Tz jacobian if(luse_obsdiag)then @@ -173,18 +165,12 @@ subroutine intsst(ssthead,rval,sval) endif ! Adjoint - if ( nst_gsi > 2 ) then - tval = sstptr%tz_tr*grad ! Extract contributions from surface jacobian - rsst(j1)=rsst(j1)+w1*tval ! Distribute adjoint contributions over surrounding grid points - rsst(j2)=rsst(j2)+w2*tval - rsst(j3)=rsst(j3)+w3*tval - rsst(j4)=rsst(j4)+w4*tval - else - rsst(j1)=rsst(j1)+w1*grad - rsst(j2)=rsst(j2)+w2*grad - rsst(j3)=rsst(j3)+w3*grad - rsst(j4)=rsst(j4)+w4*grad - endif + grad = sstptr%tz_tr*grad ! Extract contributions from surface jacobian + + rsst(j1)=rsst(j1)+w1*grad + rsst(j2)=rsst(j2)+w2*grad + rsst(j3)=rsst(j3)+w3*grad + rsst(j4)=rsst(j4)+w4*grad endif ! if (l_do_adjoint) then diff --git a/src/gsi/intt.f90 b/src/gsi/intt.f90 index 9401026e47..b4082712a9 100644 --- a/src/gsi/intt.f90 +++ b/src/gsi/intt.f90 @@ -145,7 +145,7 @@ subroutine intt_(thead,rval,sval,rpred,spred) ! Declare local variables integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus,isst,ix,n - real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8,time_t + real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8 ! real(r_kind) penalty real(r_kind) cg_t,val,grad,rat_err2,error2,t_pg,var_jb real(r_kind) psfc_grad,tg_grad @@ -160,14 +160,13 @@ subroutine intt_(thead,rval,sval,rpred,spred) ! Retrieve pointers ! Simply return if any pointer not found - ier=0; isst=0 - call gsi_bundlegetpointer(sval,'tsen', st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'tsen', st,istatus);ier=istatus call gsi_bundlegetpointer(sval,'tv', stv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'q', sq,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'u', su,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'v', sv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'prse', sp,istatus);ier=istatus+ier - call gsi_bundlegetpointer(sval,'sst',ssst,istatus);isst=istatus+isst + call gsi_bundlegetpointer(sval,'sst',ssst,istatus);isst=istatus if(ier/=0) return call gsi_bundlegetpointer(rval,'tsen', rt,istatus);ier=istatus+ier @@ -179,7 +178,6 @@ subroutine intt_(thead,rval,sval,rpred,spred) call gsi_bundlegetpointer(rval,'sst',rsst,istatus);isst=istatus+isst if(ier/=0) return - time_t=zero !tptr => thead tptr => tNode_typecast(thead) do while (associated(tptr)) @@ -205,20 +203,22 @@ subroutine intt_(thead,rval,sval,rpred,spred) !----------use surface model---------------------- + qs_prime0=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4) + us_prime0=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4) + vs_prime0=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) + psfc_prime0=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) + if(tptr%tv_ob)then ts_prime0=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4) else ts_prime0=w1*st(j1)+w2*st(j2)+w3*st(j3)+w4*st(j4) end if + if (isst==0) then tg_prime0=w1* ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) else tg_prime0=zero end if - qs_prime0=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4) - us_prime0=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4) - vs_prime0=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) - psfc_prime0=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) val=psfc_prime0*tptr%tlm_tsfc(1) + tg_prime0*tptr%tlm_tsfc(2) + & ts_prime0 *tptr%tlm_tsfc(3) + qs_prime0*tptr%tlm_tsfc(4) + & @@ -231,8 +231,8 @@ subroutine intt_(thead,rval,sval,rpred,spred) val=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4)& +w5*stv(j5)+w6*stv(j6)+w7*stv(j7)+w8*stv(j8) else - val=w1* st(j1)+w2* st(j2)+w3* st(j3)+w4* st(j4)& - +w5* st(j5)+w6* st(j6)+w7* st(j7)+w8* st(j8) + val=w1*st(j1)+ w2*st(j2)+ w3*st(j3)+ w4*st(j4)& + +w5*st(j5)+ w6*st(j6)+ w7*st(j7)+ w8*st(j8) end if end if @@ -310,21 +310,7 @@ subroutine intt_(thead,rval,sval,rpred,spred) rp(j2)=rp(j2)+w2*psfc_grad rp(j3)=rp(j3)+w3*psfc_grad rp(j4)=rp(j4)+w4*psfc_grad - vs_grad =tptr%tlm_tsfc(6)*grad - rv(j1)=rv(j1)+w1*vs_grad - rv(j2)=rv(j2)+w2*vs_grad - rv(j3)=rv(j3)+w3*vs_grad - rv(j4)=rv(j4)+w4*vs_grad - us_grad =tptr%tlm_tsfc(5)*grad - ru(j1)=ru(j1)+w1*us_grad - ru(j2)=ru(j2)+w2*us_grad - ru(j3)=ru(j3)+w3*us_grad - ru(j4)=ru(j4)+w4*us_grad - qs_grad =tptr%tlm_tsfc(4)*grad - rq(j1)=rq(j1)+w1*qs_grad - rq(j2)=rq(j2)+w2*qs_grad - rq(j3)=rq(j3)+w3*qs_grad - rq(j4)=rq(j4)+w4*qs_grad + if (isst==0) then tg_grad =tptr%tlm_tsfc(2)*grad rsst(j1)=rsst(j1)+w1*tg_grad @@ -333,22 +319,39 @@ subroutine intt_(thead,rval,sval,rpred,spred) rsst(j4)=rsst(j4)+w4*tg_grad end if - ts_grad =tptr%tlm_tsfc(3)*grad if(tptr%tv_ob)then rtv(j1)=rtv(j1)+w1*ts_grad rtv(j2)=rtv(j2)+w2*ts_grad rtv(j3)=rtv(j3)+w3*ts_grad rtv(j4)=rtv(j4)+w4*ts_grad - else rt(j1)=rt(j1)+w1*ts_grad rt(j2)=rt(j2)+w2*ts_grad rt(j3)=rt(j3)+w3*ts_grad rt(j4)=rt(j4)+w4*ts_grad - end if + qs_grad =tptr%tlm_tsfc(4)*grad + rq(j1)=rq(j1)+w1*qs_grad + rq(j2)=rq(j2)+w2*qs_grad + rq(j3)=rq(j3)+w3*qs_grad + rq(j4)=rq(j4)+w4*qs_grad + + us_grad =tptr%tlm_tsfc(5)*grad + ru(j1)=ru(j1)+w1*us_grad + ru(j2)=ru(j2)+w2*us_grad + ru(j3)=ru(j3)+w3*us_grad + ru(j4)=ru(j4)+w4*us_grad + + vs_grad =tptr%tlm_tsfc(6)*grad + rv(j1)=rv(j1)+w1*vs_grad + rv(j2)=rv(j2)+w2*vs_grad + rv(j3)=rv(j3)+w3*vs_grad + rv(j4)=rv(j4)+w4*vs_grad + + + else !------bypass surface model-------------------------- diff --git a/src/gsi/jfunc.f90 b/src/gsi/jfunc.f90 index 1b92ad2e94..616f835218 100644 --- a/src/gsi/jfunc.f90 +++ b/src/gsi/jfunc.f90 @@ -136,10 +136,12 @@ module jfunc public :: pseudo_q2 public :: varq public :: cnvw_option + public :: hofx_2m_sfcfile logical first,last,switch_on_derivatives,tendsflag,print_diag_pcg,tsensible,diag_precon logical clip_supersaturation,R_option logical pseudo_q2,limitqobs + logical hofx_2m_sfcfile logical cnvw_option integer(i_kind) iout_iter,miter,iguess,nclen,qoption,cwoption integer(i_kind) jiter,jiterstart,jiterend,iter @@ -249,6 +251,9 @@ subroutine init_jfunc ! option for including convective clouds in the all-sky assimilation cnvw_option=.false. +! option to calculate hofx for T2m and q2m by interpolating from 2m vars in sfc file + hofx_2m_sfcfile=.false. + return end subroutine init_jfunc diff --git a/src/gsi/jgrad.f90 b/src/gsi/jgrad.f90 index 2e32556465..c6e2e5415c 100755 --- a/src/gsi/jgrad.f90 +++ b/src/gsi/jgrad.f90 @@ -58,6 +58,7 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens use mpl_allreducemod, only: mpl_allreduce use obs_sensitivity, only: efsoi_o2_update +use control2state_mod, only: control2state,control2state_ad implicit none diff --git a/src/gsi/lightinfo.f90 b/src/gsi/lightinfo.f90 index b0ebcdacfd..bdd6aee392 100755 --- a/src/gsi/lightinfo.f90 +++ b/src/gsi/lightinfo.f90 @@ -205,11 +205,13 @@ subroutine lightinfo_read else ! File does not exist, write warning message to alert users - if (mype==mype_light) then - open(iout_light) - write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist' - close(iout_light) - endif +! For many usages light data is not important. Write line to output. +! if (mype==mype_light) then +! open(iout_light) +! write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist' + if(mype==mype_light)write(6,*)'LIGHTINFO_READ: FILE ',trim(fname),'does not exist' +! close(iout_light) +! endif end if return diff --git a/src/gsi/m_radNode.F90 b/src/gsi/m_radNode.F90 index 33070e8382..ae4854920a 100644 --- a/src/gsi/m_radNode.F90 +++ b/src/gsi/m_radNode.F90 @@ -57,6 +57,7 @@ module m_radNode ! square root of inverse of R, only used ! if using correlated obs + integer(i_kind),dimension(:),pointer :: iccerr => NULL() integer(i_kind),dimension(:),pointer :: icx => NULL() integer(i_kind),dimension(:),pointer :: ich => NULL() integer(i_kind) :: nchan ! number of channels for this profile @@ -214,6 +215,7 @@ subroutine obsNode_clean_(aNode) if(associated(aNode%Rpred )) deallocate(aNode%Rpred ) if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) if(associated(aNode%icx )) deallocate(aNode%icx ) + if(associated(aNode%iccerr )) deallocate(aNode%iccerr ) _EXIT_(myname_) return end subroutine obsNode_clean_ @@ -276,6 +278,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) if(associated(aNode%Rpred )) deallocate(aNode%Rpred) if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) if(associated(aNode%icx )) deallocate(aNode%icx ) + if(associated(aNode%iccerr )) deallocate(aNode%iccerr ) nchan=aNode%nchan allocate( aNode%diags(nchan), & @@ -285,7 +288,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%pred (npred,nchan), & aNode%dtb_dvar(nsigradjac,nchan), & aNode%ich (nchan), & - aNode%icx (nchan) ) + aNode%icx (nchan), aNode%iccerr(nchan) ) read(iunit,iostat=istat) aNode%ich , & aNode%res , & @@ -293,6 +296,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%raterr2 , & aNode%pred , & aNode%icx , & + aNode%iccerr , & aNode%dtb_dvar, & aNode%wij , & aNode%ij @@ -368,6 +372,7 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%raterr2 , & aNode%pred , & aNode%icx , & + aNode%iccerr , & aNode%dtb_dvar, & aNode%wij , & aNode%ij diff --git a/src/gsi/ncepgfs_io.f90 b/src/gsi/ncepgfs_io.f90 index 52dcc4e1b5..59be6d3925 100644 --- a/src/gsi/ncepgfs_io.f90 +++ b/src/gsi/ncepgfs_io.f90 @@ -1440,7 +1440,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) if ( use_gfs_nemsio ) then if ( write_fv3_incr ) then - call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + call write_fv3_increment(grd_a,filename,mype_atm, & atm_bundle,itoutsig) else if (fv3_full_hydro) then @@ -1461,7 +1461,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) else if ( use_gfs_ncio ) then if ( write_fv3_incr ) then - call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + call write_fv3_increment(grd_a,filename,mype_atm, & atm_bundle,itoutsig) else call write_gfsncatm(grd_a,sp_a,filename,mype_atm, & diff --git a/src/gsi/netcdfgfs_io.f90 b/src/gsi/netcdfgfs_io.f90 index ce32e13554..41e8f33e03 100644 --- a/src/gsi/netcdfgfs_io.f90 +++ b/src/gsi/netcdfgfs_io.f90 @@ -105,6 +105,7 @@ subroutine read_ ! ! program history log: ! 2019-09-24 Martin - create routine based on read_nems +! 2022-03-23 Draper - add option to include T2m and q2m in MetGuess ! ! input argument list: ! @@ -129,6 +130,7 @@ subroutine read_ use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info use mpimod, only: npe,mype use cloud_efr_mod, only: cloud_calc_gfs,set_cloud_lower_bound + use jfunc, only: hofx_2m_sfcfile use gridmod, only: fv3_full_hydro implicit none @@ -141,6 +143,8 @@ subroutine read_ real(r_kind),pointer,dimension(:,: ):: ges_ps_it =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_z_it =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_t2m_it =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_q2m_it =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_u_it =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_v_it =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_div_it =>NULL() @@ -164,8 +168,10 @@ subroutine read_ type(gsi_grid) :: atm_grid integer(i_kind),parameter :: n2d=2 ! integer(i_kind),parameter :: n3d=8 + integer(i_kind),parameter :: n2d_2m=4 integer(i_kind),parameter :: n3d=14 character(len=4), parameter :: vars2d(n2d) = (/ 'z ', 'ps ' /) + character(len=4), parameter :: vars2d_with2m(n2d_2m) = (/ 'z ', 'ps ','t2m ','q2m ' /) ! character(len=4), parameter :: vars3d(n3d) = (/ 'u ', 'v ', & ! 'vor ', 'div ', & ! 'tv ', 'q ', & @@ -189,8 +195,11 @@ subroutine read_ ! Allocate bundle used for reading members call gsi_gridcreate(atm_grid,lat2,lon2,nsig) - - call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) + if (hofx_2m_sfcfile) then + call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d_with2m,names3d=vars3d) + else + call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) + endif if(istatus/=0) then write(6,*) myname_,': trouble creating atm_bundle' call stop2(999) @@ -198,9 +207,15 @@ subroutine read_ do it=1,nfldsig - write(filename,'(''sigf'',i2.2)') ifilesig(it) - ! Read background fields into bundle + if (hofx_2m_sfcfile) then + if (mype==0) write(*,*) 'calling general_read_gfsatm_nc for 2m data', it + write(filename,'(''sfcf'',i2.2)') ifilesig(it) + call general_read_gfsatm_nc(grd_t,sp_a,filename,.true.,.true.,.true.,& + atm_bundle,.true.,istatus) + if (mype==0) write(*,*) 'done with general_read_gfsatm_nc for 2m data', it + end if + write(filename,'(''sigf'',i2.2)') ifilesig(it) if (fv3_full_hydro) then if (mype==0) write(*,*) 'calling general_read_gfsatm_allhydro_nc', it call general_read_gfsatm_allhydro_nc(grd_t,sp_a,filename,.true.,.true.,.true.,& @@ -273,6 +288,16 @@ subroutine set_guess_ call gsi_bundlegetpointer (gsi_metguess_bundle(it),'z' ,ges_z_it ,istatus) if(istatus==0) ges_z_it = ptr2d endif + call gsi_bundlegetpointer (atm_bundle,'t2m',ptr2d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'t2m' ,ges_t2m_it ,istatus) + if(istatus==0) ges_t2m_it = ptr2d + endif + call gsi_bundlegetpointer (atm_bundle,'q2m',ptr2d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'q2m' ,ges_q2m_it ,istatus) + if(istatus==0) ges_q2m_it = ptr2d + endif call gsi_bundlegetpointer (atm_bundle,'u',ptr3d,istatus) if (istatus==0) then call gsi_bundlegetpointer (gsi_metguess_bundle(it),'u' ,ges_u_it ,istatus) @@ -1300,7 +1325,7 @@ subroutine read_sfc_anl_(isli_anl) ! open the netCDF file sfcges = open_dataset(filename,errcode=iret) if (iret/=0) then - write(6,*) trim(my_name),': ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + write(6,*) trim(my_name),': ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' call stop2(999) endif diff --git a/src/gsi/obs_sensitivity.f90 b/src/gsi/obs_sensitivity.f90 index 880ee6384a..b6498d09fc 100644 --- a/src/gsi/obs_sensitivity.f90 +++ b/src/gsi/obs_sensitivity.f90 @@ -61,6 +61,7 @@ module obs_sensitivity use hybrid_ensemble_isotropic, only: create_ensemble,load_ensemble,destroy_ensemble use hybrid_ensemble_isotropic, only: hybens_localization_setup use mpeu_util, only: perr,die +use control2state_mod, only: control2state,control2state_ad ! ------------------------------------------------------------------------------ implicit none save diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 3dd936d94e..3066cdb5ca 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -435,8 +435,8 @@ module obsmod public :: iout_pcp,iout_rad,iadate,iadatemn,write_diag,reduce_diag,oberrflg,bflag,ndat,dthin,dmesh,l_do_adjoint public :: diag_radardbz public :: lsaveobsens - public :: iout_cldch, mype_cldch - public :: nprof_gps,time_offset,ianldate,tcp_box + public :: iout_cldch, mype_cldch + public :: nprof_gps,time_offset,ianldate,tcp_box public :: iout_oz,iout_co,dsis,ref_obs,obsfile_all,lobserver,tcp_posmatch,perturb_obs,ditype,dsfcalc,dplat public :: time_window,dval,dtype,dfile,dirname,obs_setup,oberror_tune,offtime_data public :: lobsdiagsave,lobsdiag_forenkf,blacklst,hilbert_curve,lobskeep,time_window_max,sfcmodel,ext_sonde @@ -470,7 +470,7 @@ module obsmod ! ==== DBZ DA === public :: ntilt_radarfiles public :: whichradar - public :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, l2rwthin + public :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin public :: doradaroneob,oneoblat,oneoblon public :: oneobddiff,oneobvalue,oneobheight,oneobradid @@ -617,7 +617,7 @@ module obsmod logical :: ta2tb logical :: doradaroneob - logical :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, l2rwthin + logical :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin character(4) :: whichradar,oneobradid real(r_kind) :: oneoblat,oneoblon,oneobddiff,oneobvalue,oneobheight logical :: radar_no_thinning @@ -747,6 +747,7 @@ subroutine init_obsmod_dflts if_vterminal=.false. l2rwthin =.false. if_vrobs_raw=.false. + if_use_w_vr=.true. if_model_dbz=.false. inflate_obserr=.false. whichradar="KKKK" @@ -831,7 +832,7 @@ subroutine init_obsmod_dflts iout_tcp=214 ! synthetic tc-mslp iout_lag=215 ! lagrangian tracers iout_co=216 ! co tracers - iout_aero=217 ! aerosol product (aod) + iout_aero=217 ! aerosol product (aod) CURRENTLY NOT USED iout_gust=218 ! wind gust iout_vis=219 ! visibility iout_pblh=221 ! pbl height diff --git a/src/gsi/pcgsoi.f90 b/src/gsi/pcgsoi.f90 index a4ae2431b1..fac01c9315 100644 --- a/src/gsi/pcgsoi.f90 +++ b/src/gsi/pcgsoi.f90 @@ -130,8 +130,8 @@ subroutine pcgsoi() iguess,read_guess_solution, & niter_no_qc,print_diag_pcg use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar, iwrtinc, ladtest, & - iorthomax - use gridmod, only: twodvar_regional,periodic + iorthomax,lsqrtb + use gridmod, only: twodvar_regional,periodic,minmype use constants, only: zero,one,tiny_r_kind use mpimod, only: mype use mpl_allreducemod, only: mpl_allreduce @@ -148,15 +148,17 @@ subroutine pcgsoi() use bias_predictors, only: update_bias_preds use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean use timermod, only: timer_ini,timer_fnl - use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens + use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens,aniso_a_en use gsi_bundlemod, only : gsi_bundle use gsi_bundlemod, only : self_add,assignment(=) use gsi_bundlemod, only : gsi_bundleprint + use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_4dcouplermod, only : gsi_4dcoupler_grtests use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type use gsi_io, only: verbose use berror, only: vprecond use stpjomod, only: stpjo_setup + use intradmod, only: setrad implicit none @@ -187,7 +189,7 @@ subroutine pcgsoi() type(control_vector), allocatable, dimension(:) :: cglwork type(control_vector), allocatable, dimension(:) :: cglworkhat integer(i_kind) :: iortho - logical :: print_verbose + logical :: print_verbose,ortho,diag_print logical :: lanlerr,read_success ! Step size diagnostic strings @@ -235,7 +237,9 @@ subroutine pcgsoi() nlnqc_iter=.false. call stpjo_setup(nobs_bins) + ortho=.false. if(iorthomax>0) then + ortho=.true. allocate(cglwork(iorthomax+1)) DO ii=1,iorthomax+1 CALL allocate_cv(cglwork(ii)) @@ -252,10 +256,19 @@ subroutine pcgsoi() end do sbias=zero + call setrad(sval(1)) + if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if + end if ! Perform inner iteration inner_iteration: do iter=0,niter(jiter) + + diag_print= iter <= 1 .and. print_diag_pcg -! Gradually turn on variational qc to avoid possible convergence problems +! Gradually turn on old variational qc to avoid possible convergence problems if(vqc) then nlnqc_iter = iter >= niter_no_qc(jiter) if(jiter == jiterstart) then @@ -266,17 +279,11 @@ subroutine pcgsoi() endif end if ! 1. Calculate gradient - do ii=1,nobs_bins - rval(ii)=zero - end do - rbias=zero gradx=zero - llprt=(mype==0).and.(iter<=1) -! Control to state -! call c2s(xhat,sval,sbias,llprt,.true.) + llprt=(mype==minmype).and.(iter<=1) - if (iter<=1 .and. print_diag_pcg) then + if (diag_print) then do ii=1,nobs_bins call prt_state_norms(sval(ii),'sval') enddo @@ -285,7 +292,7 @@ subroutine pcgsoi() ! Compare obs to solution and transpose back to grid call intall(sval,sbias,rval,rbias) - if (iter<=1 .and. print_diag_pcg) then + if (diag_print) then do ii=1,nobs_bins call prt_state_norms(rval(ii),'rval') enddo @@ -295,10 +302,12 @@ subroutine pcgsoi() call c2s_ad(gradx,rval,rbias,llprt) ! Print initial Jo table - if (iter==0 .and. print_diag_pcg .and. luse_obsdiag) then - nprt=2 - call evaljo(zjo,iobs,nprt,llouter) - call prt_control_norms(gradx,'gradx') + if (iter==0) then + if(print_diag_pcg .and. luse_obsdiag) then + nprt=2 + call evaljo(zjo,iobs,nprt,llouter) + call prt_control_norms(gradx,'gradx') + end if endif ! Add contribution from background term @@ -308,7 +317,7 @@ subroutine pcgsoi() ! End of gradient calculation ! Re-orthonormalization if requested - if(iorthomax>0) then + if(ortho) then iortho=min(iorthomax,iter) if(iter .ne. 0) then do ii=iortho,1,-1 @@ -323,13 +332,13 @@ subroutine pcgsoi() ! 2. Multiply by background error call multb(gradx,grady) - if(iorthomax>0) then + if(ortho) then ! save gradients if (iter <= iortho) then - zdla = sqrt(dot_product(gradx,grady,r_quad)) + zdla = one/sqrt(dot_product(gradx,grady,r_quad)) do i=1,nclen - cglwork(iter+1)%values(i)=gradx%values(i)/zdla - cglworkhat(iter+1)%values(i)=grady%values(i)/zdla + cglwork(iter+1)%values(i)=gradx%values(i)*zdla + cglworkhat(iter+1)%values(i)=grady%values(i)*zdla end do end if end if @@ -350,7 +359,7 @@ subroutine pcgsoi() ! different due to round off, so use average. gnorm(2)=dprod(2)-0.5_r_quad*(dprod(3)+dprod(4)) gnorm(3)=dprod(2) - if(mype == 0)then + if(mype == minmype)then aindex=abs(dprod(3)/dprod(2)) write(iout_iter,*) 'NL Index ',aindex if(aindex > 0.5_r_kind .or. print_verbose) write(iout_iter,*) 'NL Values ', dprod(3),dprod(2) @@ -370,7 +379,7 @@ subroutine pcgsoi() gnorm(1)=dprod(1) - if(mype == 0)write(iout_iter,*)'Minimization iteration',iter + if(mype == minmype)write(iout_iter,*)'Minimization iteration',iter ! 4. Calculate b and new search direction b=zero @@ -378,13 +387,13 @@ subroutine pcgsoi() if (iter > 1 .or. .not. read_success)then if (gsave>1.e-16_r_kind) b=gnorm(2)/gsave if (b30.0_r_kind) then - if (mype==0) then + if (mype==minmype) then if (iout_6) write(6,105) gnorm(2),gsave,b write(iout_iter,105) gnorm(2),gsave,b endif b=zero endif - if (mype==0 .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b + if (mype==minmype .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b end if do i=1,nclen @@ -432,22 +441,20 @@ subroutine pcgsoi() gnormx=gnorm(1)/gnormorig penx=penalty/penorig - if (mype==0) then + if (mype==minmype) then if (iter==0) then zgini=gnorm(1) zfini=penalty write(6,888)'Initial cost function =',zfini write(6,888)'Initial gradient norm =',sqrt(zgini) endif - if(print_verbose)then - write(iout_iter,888)'pcgsoi: gnorm(1:2)',gnorm - write(iout_iter,999)'costterms Jb,Jo,Jc,Jl =',jiter,iter,fjcost - end if istep=1 if (stp= pennorm .or. end_iter)then - if(mype == 0)then + if(mype == minmype)then if(iout_6) write(6,101) write(iout_iter,101) @@ -508,7 +515,7 @@ subroutine pcgsoi() ! End of inner iteration ! Deallocate space for renormalization - if(iorthomax>0) then + if(ortho) then do ii=1,iorthomax+1 call deallocate_cv(cglwork(ii)) enddo @@ -521,7 +528,7 @@ subroutine pcgsoi() ! Calculate adjusted observation error factor if( oberror_tune .and. (.not.l4dvar) ) then - if (mype == 0) write(6,*) 'PCGSOI: call penal for obs perturbation' + if (mype == minmype) write(6,*) 'PCGSOI: call penal for obs perturbation' ! call c2s(xhat,sval,sbias,.false.,.false.) call penal(sval(1)) @@ -535,17 +542,14 @@ subroutine pcgsoi() if (l_tlnmc .and. baldiag_inc) call strong_baldiag_inc(sval,size(sval)) - llprt=(mype==0) + llprt=(mype==minmype) ! call c2s(xhat,sval,sbias,llprt,.false.) if(print_diag_pcg)then ! Evaluate final cost function and gradient - if (mype==0) write(6,*)'Minimization final diagnostics' + if (mype==minmype) write(6,*)'Minimization final diagnostics' - do ii=1,nobs_bins - rval(ii)=zero - end do call intall(sval,sbias,rval,rbias) gradx=zero call c2s_ad(gradx,rval,rbias,llprt) @@ -575,16 +579,16 @@ subroutine pcgsoi() ! fjcost(1) = dot_product(xhatsave,yhatsave,r_quad) end if ! fjcost(2) = zjo - zfend=penaltynew -! if(l_hyb_ens) zfend=zfend+fjcost_e - if (mype==0) then + if (mype==minmype) then + zfend=penaltynew if(l_hyb_ens) then ! If hybrid ensemble run, print out contribution to Jb and Je separately write(iout_iter,999)'costterms Jb,Je,Jo,Jc,Jl =',jiter,iter,fjcostnew(1)- fjcost_e, & fjcost_e,fjcostnew(2:4) +! zfend=zfend+fjcost_e else write(iout_iter,999)'costterms Jb,Jo,Jc,Jl =',jiter,iter,fjcostnew @@ -905,6 +909,7 @@ subroutine c2s(hat,val,bias,llprt,ltest) use gsi_bundlemod, only : gsi_bundle,assignment(=) use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar use gsi_4dcouplermod, only : gsi_4dcoupler_grtests + use control2state_mod, only: control2state,control2state_ad implicit none type(control_vector) ,intent(inout) :: hat @@ -971,6 +976,7 @@ subroutine c2s_ad(hat,val,bias,llprt) use gsi_bundlemod, only : gsi_bundle,assignment(=) use gsi_bundlemod, only : self_add use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar + use control2state_mod, only: control2state_ad implicit none type(control_vector) ,intent(inout) :: hat diff --git a/src/gsi/pvqc.f90 b/src/gsi/pvqc.f90 index 81d27ba99f..3353b091a3 100755 --- a/src/gsi/pvqc.f90 +++ b/src/gsi/pvqc.f90 @@ -382,8 +382,8 @@ subroutine vqch_iii(ia,ib,ik,x,g,w)! [vqch] g=g-ya w=-w/xx else - g=-qx**2/2 - w=1 + g=-qx**2/2_dp + w=1_dp endif g=p*g end subroutine vqch_iii diff --git a/src/gsi/q_diag.f90 b/src/gsi/q_diag.f90 index 925a5775ec..15ef49c6b5 100644 --- a/src/gsi/q_diag.f90 +++ b/src/gsi/q_diag.f90 @@ -38,7 +38,7 @@ subroutine q_diag(it,mype) use mpimod, only: mpi_rtype,mpi_comm_world,mpi_sum,ierror use constants,only: zero,two,one,half use gridmod, only: lat2,lon2,nsig,nlat,nlon,lat1,lon1,iglobal,& - displs_g,ijn,wgtlats,itotsub,strip + displs_g,ijn,wgtlats,itotsub,strip,minmype use derivsmod, only: cwgues use general_commvars_mod, only: load_grid use gridmod, only: regional @@ -67,7 +67,7 @@ subroutine q_diag(it,mype) real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>NULL() - mype_out=0 + mype_out=minmype mm1=mype+1 ier=0 diff --git a/src/gsi/qcmod.f90 b/src/gsi/qcmod.f90 index f4afdbae9d..7146ceff3e 100644 --- a/src/gsi/qcmod.f90 +++ b/src/gsi/qcmod.f90 @@ -2311,7 +2311,6 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & 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 @@ -2320,12 +2319,10 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! If more than 2% of the transmittance comes from the cloud layer, ! reject the channel (0.02 is a tunable parameter) - delta = 0.02_r_kind if ( ptau5(lcloud,i) > 0.02_r_kind) then ! QC4 in statsrad if(luse)aivals(11,is) = aivals(11,is) + one varinv(i) = zero - varinv_use(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc end if end do @@ -2353,8 +2350,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & 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 + 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 @@ -2369,8 +2365,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & 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 + 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 @@ -2435,75 +2430,68 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & if(hirs) then do i=1,nchanl m=ich(i) - if (iomg_det(m) > 0 .and. i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif -!90S-60S - if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif -!60S-30S - else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then + if(iomg_det(m) > 0 .and. i >= 4 .and. i <= 12)then + if (i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then varinv(i) = zero if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then + else if(i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then varinv(i) = zero if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det endif +!90S-60S + if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif +!60S-30S + else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if( i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif !30S-30N - else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif + else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind ) then + if(i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif !30N-60N - else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - endif !cenlat + else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + endif !cenlat + end if if (itopo_det(m) > 0 .and. zsges > 1500.0_r_kind) then varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det endif end do endif !! if (hirs) @@ -2990,13 +2978,11 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & dsval=((2.41_r_kind-0.0098_r_kind*tb_obsbc1)*tbc(ich238) + & 0.454_r_kind*tbc(ich314)-tbc(ich890))*w1f6 dsval=max(zero,dsval) - end if - - if(sea)then clwx=cosza*clw*w1f4 else clwx=0.6_r_kind end if + ! QC6 in statsrad if(clwx >= one .and. luse)aivals(13,is) = aivals(13,is) + one factch4=clwx**2+(tbc(ich528)*w2f4)**2 diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90 index 76a08c39a5..ffc4641696 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -615,7 +615,7 @@ subroutine radinfo_read ! !USES: use obsmod, only: iout_rad - use constants, only: zero,one,zero_quad + use constants, only: zero,one,zero_quad, r10 use mpimod, only: mype use mpeu_util, only: perr,die implicit none @@ -855,7 +855,8 @@ subroutine radinfo_read varA(i,j)=varx(i) end do ostats(j)=ostatsx - if ((any(varx/=zero) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) & + if ((all(varx==zero) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) cycle read3 + if ((any(varx/=r10) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) & inew_rad(j)=.false. cycle read3 end if @@ -1740,7 +1741,7 @@ subroutine init_predx if (.not. (any(inew_rad) .or. any(update_tlapmean))) return if (ndat==0) return - if (mype==0) write(6,*) 'INIT_PREDX: enter routine' +! if (mype==0) write(6,*) 'INIT_PREDX: enter routine' ! Allocate and initialize data arrays if (any(update_tlapmean)) then @@ -1867,6 +1868,7 @@ subroutine init_predx end do end do loop_a + write(6,*) 'INIT_PREDX: inst_sat new_chan = ', trim(fdiag_rad), new_chan if (.not. update .and. new_chan==0) then call close_radiag(fdiag_rad,lndiag) cycle loopf diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index 9f5efb5301..47b675b3a3 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -511,10 +511,10 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ALLOCATE(Relative_Time_In_Seconds(Num_Obs)) ALLOCATE(IScan(Num_Obs)) Relative_Time_In_Seconds = 3600.0_r_kind*T4DV_Save(1:Num_Obs) - write(6,*) 'Calling ATMS_Spatial_Average' +! write(6,*) 'Calling ATMS_Spatial_Average' CALL ATMS_Spatial_Average(Num_Obs, NChanl, IFOV_Save(1:Num_Obs), & Relative_Time_In_Seconds, BT_Save(1:nchanl,1:Num_Obs), IScan, IRet) - write(6,*) 'ATMS_Spatial_Average Called with IRet=',IRet +! write(6,*) 'ATMS_Spatial_Average Called with IRet=',IRet DEALLOCATE(Relative_Time_In_Seconds) IF (IRet /= 0) THEN diff --git a/src/gsi/read_bufrtovs.f90 b/src/gsi/read_bufrtovs.f90 index 0aed801ee5..0c954c7c1d 100644 --- a/src/gsi/read_bufrtovs.f90 +++ b/src/gsi/read_bufrtovs.f90 @@ -228,7 +228,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& real(r_kind),allocatable,dimension(:,:):: data_all real(crtm_kind),allocatable,dimension(:):: data1b4 - real(r_double),allocatable,dimension(:):: data1b8,data1b8x + real(r_double),allocatable,dimension(:):: data1b8 real(r_double),dimension(n1bhdr):: bfr1bhdr real(r_double),dimension(n2bhdr):: bfr2bhdr @@ -519,7 +519,6 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! support multiple spc coefficient files for any given sensor if(amsua .or. amsub .or. mhs)then quiet=.not.verbose - allocate(data1b8x(nchanl)) spc_coeff_versions = 0 spc_coeff_found = .true. do while (spc_coeff_found) @@ -748,13 +747,15 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! unless the satellite is n15 or n16, because tranamsua ! does this conversion because the coefficient files exist ! for it to use - data1b8x=data1b8 data1b4=data1b8 !call apply_antcorr(accoeff_sets(spc_coeff_versions),ifov,data1b4) call apply_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000) data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000)then + data1b8(j) = 1000000._r_kind + else + data1b8(j) = data1b4(j) + end if end do end if else ! EARS / DB @@ -766,14 +767,16 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! data originator, ! then convert back to brightness temperature using the version ! of parameters used by the CRTM - data1b8x=data1b8 data1b4=data1b8 call remove_antcorr(accoeff_sets(sacv),ifov,data1b4) !call apply_antcorr(accoeff_sets(spc_coeff_versions),ifov,data1b4) call apply_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000) data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000) then + data1b8(j) = 1000000._r_kind + else + data1b8(j)=data1b4(j) + end if end do end if end if @@ -785,12 +788,14 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& else ! EARS / DB call ufbrep(lnbufr,data1b8,1,nchanl,iret,'TMBRST') if ( amsua .or. amsub .or. mhs )then - data1b8x=data1b8 data1b4=data1b8 call remove_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000)data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000)then + data1b8(j) = 1000000._r_kind + else + data1b8(j) = data1b4(j) + end if end do end if end if @@ -1053,8 +1058,6 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& call closbf(lnbufr) close(lnbufr) - if (allocated(data1b8x)) deallocate(data1b8x) - end do ears_db_loop deallocate(data1b8,data1b4) diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index ee1d3cb2e4..cddbd14de4 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -71,7 +71,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no one_tenth,r1000,r60,r60inv,r100,r400,grav_equator, & eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening use gridmod, only: tll2xy,nsig,nlat,nlon - use obsmod, only: iadate,doradaroneob,oneoblat,oneoblon,oneobheight,oneobradid, & + use obsmod, only: iadate,doradaroneob,oneoblat,oneoblon,oneobheight, & mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz,& static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz use hybrid_ensemble_parameters,only : l_hyb_ens diff --git a/src/gsi/read_diag.f90 b/src/gsi/read_diag.f90 index 6a7fa44cb9..e389a708d5 100644 --- a/src/gsi/read_diag.f90 +++ b/src/gsi/read_diag.f90 @@ -1165,7 +1165,9 @@ subroutine read_radiag_data_nc(diag_status,header_fix,data_fix,data_chan,data_ex data_fix = diag_status%all_data_fix(diag_status%cur_ob_idx) data_chan(:) = diag_status%all_data_chan(diag_status%cur_ob_idx,:) - data_extra(:,:) = diag_status%all_data_extra(diag_status%cur_ob_idx,:,:) + if (header_fix%iextra > 0) then + data_extra(:,:) = diag_status%all_data_extra(diag_status%cur_ob_idx,:,:) + endif diag_status%cur_ob_idx = diag_status%cur_ob_idx + 1 diff --git a/src/gsi/read_files.f90 b/src/gsi/read_files.f90 index 93ddd17bf7..5d29efbace 100644 --- a/src/gsi/read_files.f90 +++ b/src/gsi/read_files.f90 @@ -620,7 +620,7 @@ subroutine read_files(mype) endif if (l4densvar .and. nfldsig/=ntlevs_ens) then if (mype==0) then - write(6,*)'READ_FILES: ***ERROR*** insufficient atm fcst for 4densvar: PROGRAM STOPS' + write(6,*)'READ_FILES: ***FATAL ERROR*** insufficient atm fcst for 4densvar: PROGRAM STOPS' do i=1,ntlevs_ens ihr=nhr_obsbin*(i-1)+nhr_half present=.false. @@ -629,7 +629,7 @@ subroutine read_files(mype) end do if (.not.present) then write(filename,'(''sigf'',i2.2)')ihr - write(6,*)'READ_FILES: ***ERROR*** file ',trim(filename),' missing: PROGRAM STOPS' + write(6,*)'READ_FILES: ***FATAL ERROR*** file ',trim(filename),' missing: PROGRAM STOPS' endif end do endif @@ -652,7 +652,7 @@ subroutine read_files(mype) endif if (l4densvar .and. nfldsfc/=ntlevs_ens) then if (mype==0) then - write(6,*)'READ_FILES: ***ERROR*** insufficient sfc fcst for 4densvar: PROGRAM STOPS' + write(6,*)'READ_FILES: ***FATAL ERROR*** insufficient sfc fcst for 4densvar: PROGRAM STOPS' do i=1,ntlevs_ens ihr=nhr_obsbin*(i-1)+nhr_half present=.false. @@ -661,7 +661,7 @@ subroutine read_files(mype) end do if (.not.present) then write(filename,'(''sfcf'',i2.2)')ihr - write(6,*)'READ_FILES: ***ERROR*** file ',trim(filename),' missing: PROGRAM STOPS' + write(6,*)'READ_FILES: ***FATAL ERROR*** file ',trim(filename),' missing: PROGRAM STOPS' endif end do endif diff --git a/src/gsi/read_gps.f90 b/src/gsi/read_gps.f90 index 3d8379ee3b..c0cef658a6 100644 --- a/src/gsi/read_gps.f90 +++ b/src/gsi/read_gps.f90 @@ -368,8 +368,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & good=.true. if((abs(rlat)>90._r_kind).or.(abs(rlon)>r360).or.(height<=zero)) then good=.false. - endif - if (ref_obs) then + else if (ref_obs) then if ((ref>=1.e+9_r_kind).or.(ref<=zero).or.(height>=1.e+9_r_kind)) then good=.false. endif @@ -466,8 +465,9 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & write(6,*)'READ_GPS: # bad or missing data=', notgood do i=1,ngpsro_type if (nmrecs_id(i)>0) & - write(6,1020)'READ_GPS: LEO_id,nprof_gps = ',gpsro_itype(i),nmrecs_id(i) + write(6,1021)'READ_GPS: LEO_id,nprof_gps = ',gpsro_itype(i),nmrecs_id(i) end do +1021 format(a31,i6,i6) write(6,1020)'READ_GPS: ref_obs,nprof_gps= ',ref_obs,nprof_gps 1020 format(a31,L,i6) diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index 367c224508..208b333f49 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -175,7 +175,6 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& character(len=4) :: senname character(len=80) :: allspotlist character(len=40) :: infile2 - integer(i_kind) :: jstart integer(i_kind) :: iret,ireadsb,ireadmg,irec,next, nrec_startx integer(i_kind),allocatable,dimension(:) :: nrec @@ -202,6 +201,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind),dimension(0:3) :: ts real(r_kind),dimension(10) :: sscale real(crtm_kind),allocatable,dimension(:) :: temperature + real(r_kind),allocatable,dimension(:) :: scalef real(r_kind),allocatable,dimension(:,:):: data_all real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00 @@ -238,7 +238,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& integer(i_kind),parameter :: ilon = 3 integer(i_kind),parameter :: ilat = 4 real(r_kind) :: ptime,timeinflat,crit0 - integer(i_kind) :: ithin_time,n_tbin,it_mesh + integer(i_kind) :: ithin_time,n_tbin,it_mesh,jstart logical print_verbose print_verbose=.false. @@ -396,6 +396,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& allocate(temperature(1)) ! dependent on # of channels in the bufr file allocate(allchan(2,1)) ! actual values set after ireadsb allocate(bufr_chan_test(1))! actual values set after ireadsb + allocate(scalef(1)) ! Big loop to read data file next=0 @@ -442,10 +443,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& bufr_size = size(temperature,1) if ( bufr_size /= bufr_nchan ) then ! Re-allocation if number of channels has changed ! Allocate the arrays needed for the channel and radiance array - deallocate(temperature,allchan,bufr_chan_test) + deallocate(temperature,allchan,bufr_chan_test,scalef) allocate(temperature(bufr_nchan)) ! dependent on # of channels in the bufr file allocate(allchan(2,bufr_nchan)) allocate(bufr_chan_test(bufr_nchan)) + allocate(scalef(bufr_nchan)) bufr_chan_test(:)=0 endif ! allocation if @@ -675,6 +677,18 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Read IASI channel number(CHNM) and radiance (SCRA) call ufbseq(lnbufr,allchan,2,bufr_nchan,iret,'IASICHN') + jstart=1 + scalef=one + do i=1,bufr_nchan + scaleloop: do j=jstart,10 + if(allchan(1,i) >= cscale(1,j) .and. allchan(1,i) <= cscale(2,j))then + scalef(i) = sscale(j) + jstart=j + exit scaleloop + end if + end do scaleloop + end do + if (iret /= bufr_nchan) then write(6,*)'READ_IASI: ### ERROR IN READING ', senname, ' BUFR DATA:', & iret, ' CH DATA IS READ INSTEAD OF ',bufr_nchan @@ -703,52 +717,47 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& cycle read_loop endif - iskip = 0 - jstart=1 +!$omp parallel do schedule(dynamic,1) private(i,sc_chan,bufr_chan,radiance) channel_loop: do i=1,satinfo_nchan - sc_chan = sc_index(i) - if ( bufr_index(i) == 0 ) cycle channel_loop bufr_chan = bufr_index(i) + if (bufr_chan > 0 ) then ! check that channel number is within reason - if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds - radiance = allchan(2,bufr_chan) - scaleloop: do j=jstart,10 - if(allchan(1,bufr_chan) >= cscale(1,j) .and. allchan(1,bufr_chan) <= cscale(2,j))then - radiance = allchan(2,bufr_chan)*sscale(j) - jstart=j - exit scaleloop - end if - end do scaleloop - call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) - else - temperature(bufr_chan) = tbmin - endif + 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)) + else + temperature(bufr_chan) = tbmin + endif + end if end do channel_loop ! Check for reasonable temperature values + iskip = 0 skip_loop: do i=1,satinfo_nchan if ( bufr_index(i) == 0 ) cycle skip_loop bufr_chan = bufr_index(i) if(temperature(bufr_chan) <= tbmin .or. temperature(bufr_chan) > tbmax ) then - temperature(bufr_chan) = min(tbmax,max(zero,temperature(bufr_chan))) + temperature(bufr_chan) = min(tbmax,max(tbmin,temperature(bufr_chan))) if(iuse_rad(ioff+i) >= 0)iskip = iskip + 1 endif end do skip_loop - if(iskip > 0 .and. print_verbose)write(6,*) ' READ_IASI : iskip > 0 ',iskip - if( iskip > 0 )cycle read_loop + if(iskip > 0)then + if(print_verbose)write(6,*) ' READ_IASI : iskip > 0 ',iskip + cycle read_loop + end if - crit1=crit1 + ten*float(iskip) +! crit1=crit1 + ten*float(iskip) ! If the surface channel exists (~960.0 cm-1) and the AVHRR 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) pred = max(pred,zero) + crit1=crit1 + pred endif - crit1=crit1 + pred - ! Map obs to grids if (pred == zero) then call finalcheck(dist1,crit1,itx,iuse) @@ -818,11 +827,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Put satinfo defined channel temperatures into data array do l=1,satinfo_nchan i = bufr_index(l) - if ( bufr_index(l) /= 0 ) then - data_all(l+nreal,itx) = temperature(i) ! brightness temerature - else - data_all(l+nreal,itx) = tbmin - endif + data_all(l+nreal,itx) = temperature(i) ! brightness temerature end do nrec(itx)=irec @@ -835,7 +840,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& end do ears_db_loop - deallocate(temperature, allchan, bufr_chan_test) + deallocate(temperature, allchan, bufr_chan_test,scalef) deallocate(channel_number,sc_index) deallocate(bufr_index) ! deallocate crtm info diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 53b0723953..9017c498c2 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -221,9 +221,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) lexist=.false. end if if(lexist)then - if(jsatid == '')then - kidsat=0 - else if(jsatid == 'metop-a')then + kidsat=0 + if(jsatid == 'metop-a')then kidsat=4 else if(jsatid == 'metop-b')then kidsat=3 @@ -335,8 +334,6 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) ! kidsat = 288 else if ( jsatid == 'meghat' ) then kidsat = 440 - else - kidsat = 0 end if call closbf(lnbufr) @@ -346,8 +343,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) call datelen(10) if(kidsat /= 0)then - lexist = .false. - satloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) + lexist = .false. + satloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) if(ireadsb(lnbufr)==0)then call ufbint(lnbufr,satid,1,1,iret,'SAID') end if @@ -356,8 +353,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) exit satloop end if nread = nread + 1 - end do satloop - else if(trim(filename) == 'prepbufr')then ! RTod: wired-in filename is not a good idea + end do satloop + else if(trim(filename) == 'prepbufr')then lexist = .false. fileloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) do while(ireadsb(lnbufr)>=0) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index d2cb503926..355441e209 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -148,6 +148,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! ! 2020-05-04 wu - no rotate_wind for fv3_regional ! 2020-09-05 CAPS(C. Tong) - add flag for new vadwind obs to assimilate around the analysis time only +! 2023-03-23 draper - add code for processing T2m and q2m for global system ! input argument list: ! infile - unit from which to read BUFR data @@ -212,7 +213,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use hilbertcurve,only: init_hilbertcurve, accum_hilbertcurve, & apply_hilbertcurve,destroy_hilbertcurve use ndfdgrids,only: init_ndfdgrid,destroy_ndfdgrid,relocsfcob,adjust_error - use jfunc, only: tsensible + use jfunc, only: tsensible, hofx_2m_sfcfile use deter_sfc_mod, only: deter_sfc_type,deter_sfc2 use gsi_nstcouplermod, only: nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_deter @@ -263,7 +264,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& logical tob,qob,uvob,spdob,sstob,pwob,psob,gustob,visob,tdob,mxtmob,mitmob,pmob,howvob,cldchob logical metarcldobs,goesctpobs,tcamtob,lcbasob logical outside,driftl,convobs,inflate_error - logical sfctype + logical sfctype, global_2m_land logical luse,ithinp,windcorr logical patch_fog logical aircraftset,aircraftobs,aircraftobst,aircrafttype @@ -475,7 +476,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(tob)then nreal=25 else if(uvob) then - nreal=27 + nreal=26 else if(spdob) then nreal=24 else if(psob) then @@ -1614,10 +1615,15 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& pmq(k)=nint(qcmark(8,k)) end do +! 181, 183, 187, and 188 are the screen-level obs over land + global_2m_land = ( (kx==181 .or. kx==183 .or. kx==188 .or. kx==188 ) .and. hofx_2m_sfcfile ) + ! If temperature ob, extract information regarding virtual ! versus sensible temperature if(tob) then - if (.not. twodvar_regional .or. .not.tsensible) then + ! use tvirtual if tsensible flag not set, and not in either 2Dregional or global_2m DA mode + if ( (.not. tsensible) .and. .not. (twodvar_regional .or. global_2m_land) ) then + do k=1,levs tvflg(k)=one ! initialize as sensible do j=1,20 @@ -1914,6 +1920,26 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Missing Values ==> Cycling! In this case for howv only. #ww3 if (howvob .and. owave(1,k) > r0_1_bmiss) cycle LOOP_K_LEVS +! Over-ride QM=9 and hard-wire errors for land obs and hofx_sfc_file option +! Can be deleted once prepbufr processing updated. + if ( global_2m_land ) then + if (tob .and. qm==9 ) then + pqm(k)=2 ! otherwise, type 183 will be discarded. + qm=2 + tqm(k)=2 + if (kx==187) obserr(3,k)=2.2 + if (kx==181) obserr(3,k)=1.5 + if (kx==183) obserr(3,k)=2.6 + endif + if (qob .and. qm == 9 ) then + qm = 2 + ! qob err specified as fraction of qsat, multiplied by 10. + if (kx==187) obserr(2,k)=1.0 + if (kx==181) obserr(2,k)=1.0 + if (kx==183) obserr(2,k)=1.0 + endif + + endif ! Set usage variable usage = zero if(icuse(nc) <= 0)usage=100._r_kind @@ -1957,6 +1983,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(obsdat(12,k) > 32.2_r_kind) usage=118._r_kind ! > 90F endif endif + ! to-do: should we add qob checks from above for landsfctype too? if ((kx>129.and.kx<140).or.(kx>229.and.kx<240) ) then call get_aircraft_usagerj(kx,obstype,c_station_id,usage) @@ -2239,8 +2266,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& cdata_all(25,iout)=var_jb(5,k) ! non linear qc parameter cdata_all(26,iout)=one ! hilbert curve weight, modified later if(perturb_obs)then - cdata_all(28,iout)=ran01dom()*perturb_fact ! u perturbation - cdata_all(29,iout)=ran01dom()*perturb_fact ! v perturbation + cdata_all(27,iout)=ran01dom()*perturb_fact ! u perturbation + cdata_all(28,iout)=ran01dom()*perturb_fact ! v perturbation endif else if(spdob) then @@ -3057,7 +3084,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& do k=1,ndata ikx=nint(cdata_out(10,k)) - itype=ictype(ikx) + if (ikx>0) then + itype=ictype(ikx) + else + itype=0 + endif if( itype ==230 .or. itype ==231 .or. itype ==233) then prest=r10*exp(cdata_out(4,k)) if (prest <100.0_r_kind) cycle diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index 874483c86e..7a372b9e15 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -74,8 +74,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! or hilber curve downweighting ! ! 2020-05-04 wu - no rotate_wind for fv3_regional -! 2021-07-25 Genkova - read GOES-17 AMVQ flag:8-mitigated height -! 16-mit.target, 24-mit.target & height; write in diag ! 2021-07-25 Genkova - added code for Metop-B/C winds in new BUFR,NC005081 ! ! 2022-01-20 Genkova - added missing station_id for polar winds ! 2022-01-20 Genkova - added code for Meteosat and Himawari AMVs in new BUFR @@ -212,7 +210,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis real(r_kind),dimension(nsig):: presl real(r_double),dimension(13):: hdrdat - real(r_double),dimension(5):: obsdat + real(r_double),dimension(4):: obsdat real(r_double),dimension(2) :: hdrdat_test real(r_double),dimension(3,5) :: heightdat real(r_double),dimension(6,4) :: derdwdat @@ -242,8 +240,8 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis data hdrtr_v2 /'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SWCM SAZA OGCE SCCF SWQM'/ ! OGCE replaces GCLONG, OGCE exists in old and new BUFR ! SWQM doesn't exist in the new BUFR, so qm is initialized to '2' manually - data obstr_v1 /'HAMD PRLC WDIR WSPD AMVQ'/ - data obstr_v2 /'EHAM PRLC WDIR WSPD AMVQ'/ + data obstr_v1 /'HAMD PRLC WDIR WSPD'/ + data obstr_v2 /'EHAM PRLC WDIR WSPD'/ ! data heightr/'MDPT '/ ! data derdwtr/'TWIND'/ data qcstr /' OGCE GNAP PCCF'/ @@ -271,7 +269,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Set lower limits for observation errors werrmin=one nsattype=0 - nreal=27 + nreal=26 if(perturb_obs ) nreal=nreal+2 ntread=1 ntmatch=0 @@ -644,10 +642,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis call ufbint(lunin,hdrdat_test,2,1,iret, 'CLAT CLON') if ( hdrdat_test(1) > 100000000.0_r_kind .and. hdrdat_test(2) > 100000000.0_r_kind ) then call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v2) - call ufbint(lunin,obsdat,5,1,iret,obstr_v2) + call ufbint(lunin,obsdat,4,1,iret,obstr_v2) else call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v1) - call ufbint(lunin,obsdat,5,1,iret,obstr_v1) + call ufbint(lunin,obsdat,4,1,iret,obstr_v1) endif ppb=obsdat(2) @@ -1208,7 +1206,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis else if(itype==240 .or. itype==245 .or. itype==246 .or. itype==251) then ! types 245 and 246 have been used to determine the acceptable pct1 range, but that pct1 range is applied to all GOES-R winds - if (pct1 < 0.04_r_kind) qm=15 + if (pct1 < 0.04_r_kind) qm=15 if (pct1 > 0.50_r_kind) qm=15 endif endif @@ -1586,11 +1584,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name cdata_all(25,iout)=var_jb ! non linear qc parameter cdata_all(26,iout)=one ! hilbert curve weight - cdata_all(27,iout)=obsdat(5) ! AMVQ for GOES-17 mitig.AMVs if(perturb_obs)then - cdata_all(28,iout)=ran01dom()*perturb_fact ! u perturbation - cdata_all(29,iout)=ran01dom()*perturb_fact ! v perturbation + cdata_all(27,iout)=ran01dom()*perturb_fact ! u perturbation + cdata_all(28,iout)=ran01dom()*perturb_fact ! v perturbation endif enddo loop_readsb diff --git a/src/gsi/setupcldtot.F90 b/src/gsi/setupcldtot.F90 index 3d899d1a82..a30ef92a90 100755 --- a/src/gsi/setupcldtot.F90 +++ b/src/gsi/setupcldtot.F90 @@ -90,7 +90,7 @@ subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_di integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index + integer(i_kind) ,intent(in ) :: is ! ndat index logical ,intent(in ) :: conv_diagsave #ifdef RR_CLOUDANALYSIS diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 1e158de9ea..96f0378c52 100644 --- a/src/gsi/setupdbz.f90 +++ b/src/gsi/setupdbz.f90 @@ -426,6 +426,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d if (lobsdiagsave) nreal=nreal+4*miter+1 if (.not.allocated(cdiagbuf)) allocate(cdiagbuf(nobs)) if (.not.allocated(rdiagbuf)) allocate(rdiagbuf(nreal,nobs)) + if(netcdf_diag) call init_netcdf_diag_ end if mm1=mype+1 scale=one @@ -1447,15 +1448,16 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d ! Release memory of local guess arrays call final_vars_ - ! Write information to diagnostic file - if(radardbz_diagsave .and. ii>0 )then + if(radardbz_diagsave .and. netcdf_diag) call nc_diag_write + if(radardbz_diagsave .and. binary_diag .and. ii>0 )then - if( .not. l_use_dbz_directDA )then + if( .not. l_use_dbz_directDA .and. .not. if_model_dbz )then write(7)'dbz',nchar,nreal,ii,mype,ioff0 write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) deallocate(cdiagbuf,rdiagbuf) else + write(string,600) jiter 600 format('radardbz_',i2.2) diag_file=trim(dirname) // trim(string) @@ -1779,7 +1781,7 @@ subroutine init_netcdf_diag_ end if call nc_diag_init(diag_conv_file, append=append_diag) - + if (.not. append_diag) then ! don't write headers on append - the module will break? call nc_diag_header("date_time",ianldate ) call nc_diag_header("Number_of_state_vars", nsdim ) diff --git a/src/gsi/setuppcp.f90 b/src/gsi/setuppcp.f90 index 970bc5b9af..8a6c8c0d80 100644 --- a/src/gsi/setuppcp.f90 +++ b/src/gsi/setuppcp.f90 @@ -223,7 +223,7 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,& character(12) string character(128) diag_pcp_file - integer(i_kind) km1,mm1,iiflg,iextra,ireal + integer(i_kind) km1,mm1,iextra,ireal integer(i_kind) ii,i,j,k,m,n,ibin,ioff,ioff0 integer(i_kind) ipt integer(i_kind) nsphys,ixp,iyp,ixx,iyy @@ -325,7 +325,6 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,& ! ONE TIME, INITIAL SETUP PRIOR TO PROCESSING SATELLITE DATA ! ! Initialize variables - iiflg = 1 ncloud = ncld nsphys = max(int(two*deltim/dtphys+0.9999_r_kind),1) dtp = two*deltim/nsphys diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index ed9fbb13db..554fe3e3dd 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -111,6 +111,8 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! information in diagonostic file, which is used ! in offline observation quality control program (AutoObsQC) ! for 3D-RTMA (if l_obsprvdiag is true). +! 2023-03-09 Draper added option to interpolate screen-level q from model 2m output. +! (hofx_2m_sfcfile) ! ! ! input argument list: @@ -160,7 +162,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav use constants, only: huge_single,wgtlim,three use constants, only: tiny_r_kind,five,half,two,huge_r_kind,r0_01 use qcmod, only: npres_print,ptopq,pbotq,dfact,dfact1,njqc,vqc,nvqc - use jfunc, only: jiter,last,jiterstart,miter,superfact,limitqobs + use jfunc, only: jiter,last,jiterstart,miter,superfact,limitqobs,hofx_2m_sfcfile use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype use convinfo, only: ibeta,ikapa use convinfo, only: icsubtype @@ -217,7 +219,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! Declare local variables real(r_double) rstation_id - real(r_kind) qob,qges,qsges,q2mges,q2mges_water + real(r_kind) qob,qges,qsges,q2mges,q2mges_water,qsges_o real(r_kind) ratio_errors,dlat,dlon,dtime,dpres,rmaxerr,error real(r_kind) rsig,dprpx,rlow,rhgh,presq,tfact,ramp real(r_kind) psges,sfcchk,ddiff,errorx @@ -231,6 +233,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav real(r_kind),dimension(nobs):: dup real(r_kind),dimension(lat2,lon2,nsig,nfldsig):: qg real(r_kind),dimension(lat2,lon2,nfldsig):: qg2m + real(r_kind),dimension(lat2,lon2,nfldsig):: qg2m_o real(r_kind),dimension(nsig):: prsltmp real(r_kind),dimension(34):: ptablq real(r_single),allocatable,dimension(:,:)::rdiagbuf @@ -277,10 +280,22 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q real(r_kind),allocatable,dimension(:,:,: ) :: ges_q2m + real(r_kind),allocatable,dimension(:,:,: ) :: ges_t2m logical:: l_pbl_pseudo_itype integer(i_kind):: ich0 type(obsLList),pointer,dimension(:):: qhead + + logical :: landsfctype + + real(r_kind) :: delta_z, lapse_error, q_delta_terrain + real(r_kind), parameter :: T_lapse = -0.0045 ! standard lapse rate, K/m +! use 4.5 K/km, in place of more standard 6.5 K/km, following +! https://agupubs.onlinelibrary.wiley.com/doi/10.1029/2019EA000984 +! lapse_error_frac around 0.5 ~ 2K/km, from Figure 2 of above. + real(r_kind), parameter :: lapse_error_frac = 0.5 ! inflation factor for obs error when vertically interpolating + real(r_kind), parameter :: max_delta_z = 300. ! max. vertical mismatch allowed (later: relax this) + qhead => obsLL(:) save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf @@ -359,8 +374,11 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav hr_offset=min_offset/60.0_r_kind dup=one do k=1,nobs + ikx=nint(data(ikxx,k)) + itype=ictype(ikx) + landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 ) do l=k+1,nobs - if (twodvar_regional) then + if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then duplogic=data(ilat,k) == data(ilat,l) .and. & data(ilon,k) == data(ilon,l) .and. & data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & @@ -425,9 +443,15 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ice=.false. ! get larger (in rh) q obs error for mixed and ice phases iderivative=0 + + ! calculate qsat and 2m qsat do jj=1,nfldsig - call genqsat(qg(1,1,1,jj),ges_tsen(1,1,1,jj),ges_prsl(1,1,1,jj),lat2,lon2,nsig,ice,iderivative) - qg2m(:,:,jj)=qg(:,:,1,jj) + call genqsat(qg(:,:,:,jj),ges_tsen(:,:,:,jj),ges_prsl(:,:,:,jj),lat2,lon2,nsig,ice,iderivative) + if (i_use_2mq4b > 0) then ! use lowest model level + qg2m(:,:,jj)=qg(:,:,1,jj) + elseif ( hofx_2m_sfcfile ) then ! calculate from 2m model output + call genqsat(qg2m(:,:,jj),ges_t2m(:,:,jj),ges_ps(:,:,jj),lat2,lon2,1,ice,iderivative) + endif end do @@ -440,10 +464,10 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call dtime_check(dtime, in_curbin, in_anybin) if(.not.in_anybin) cycle + landsfctype =( itype==181 .or. itype==183 .or. itype==187 ) ! Flag static conditions to create PBL_pseudo_surfobsq obs. - l_pbl_pseudo_itype = l_pbl_pseudo_surfobsq .and. & - ( itype==181 .or. itype==183 .or.itype==187 ) + l_pbl_pseudo_itype = l_pbl_pseudo_surfobsq .and. landsfctype if(in_curbin) then ! Convert obs lats and lons to grid coordinates @@ -509,24 +533,28 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav presq=r10*exp(dpres) itype=ictype(ikx) dprpx=zero - if(((itype > 179 .and. itype < 190) .or. itype == 199) & + + if ( hofx_2m_sfcfile .and. landsfctype) then + dpres = one ! put obs on surface + else + if(((itype > 179 .and. itype < 190) .or. itype == 199) & .and. .not.twodvar_regional)then - dprpx=abs(one-exp(dpres-log(psges)))*r10 - end if + dprpx=abs(one-exp(dpres-log(psges)))*r10 + endif ! Put obs pressure in correct units to get grid coord. number - call grdcrd1(dpres,prsltmp(1),nsig,-1) + call grdcrd1(dpres,prsltmp(1),nsig,-1) ! Get approximate k value of surface by using surface pressure - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp(1),nsig,-1) + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp(1),nsig,-1) ! Check to see if observations is above the top of the model (regional mode) - if( dpres>=nsig+1)dprpx=1.e6_r_kind - if((itype > 179 .and. itype < 186) .or. itype == 199) dpres=one + if( dpres>=nsig+1)dprpx=1.e6_r_kind + if((itype > 179 .and. itype < 186) .or. itype == 199) dpres=one + + endif -! Scale errors by guess saturation q - qob = data(iqob,i) if(limitqobs) then call tintrp31(ges_qsat,qsges,dlat,dlon,dpres,dtime,hrdifsig,& @@ -534,11 +562,13 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav qob=min(qob,superfact*qsges) end if +! get qsges, to be used to scale the obs error call tintrp31(qg,qsges,dlat,dlon,dpres,dtime,hrdifsig,& mype,nfldsig) -! Interpolate 2-m qs to obs locations/times - if((i_use_2mq4b > 0) .and. ((itype > 179 .and. itype < 190) .or. itype == 199) & - .and. .not.twodvar_regional)then + +! overwrite qsges with 2-m qs if sfc obs scheme + if( ( (i_use_2mq4b > 0) .and. ((itype > 179 .and. itype < 190) .or. itype == 199) & + .and. .not.twodvar_regional) .or. (hofx_2m_sfcfile .and. landsfctype) )then call tintrp2a11(qg2m,qsges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) endif @@ -549,10 +579,36 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav rmaxerr=max(small2,rmaxerr) errorx =(data(ier,i)+dprpx)*qsges -! Interpolate guess moisture to observation location and time - call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - +! qges: Interpolate guess moisture to observation location and time + + if (.not. ( hofx_2m_sfcfile .and. landsfctype) ) then + call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + else + ! only use land locations + if (int(data(idomsfc,i)) .NE. 1 ) muse(i) = .false. + + call tintrp2a11(ges_q2m,qges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) + + ! terrain correction: assume RH_zo = RH_zm, and correct T with + ! same lapse rate as used for T2m terrain correction + + delta_z = data(istnelv,i) - data(izz,i) ! obs -model + + do jj=1,nfldsig + ! qsat in model at height of obs + call genqsat(qg2m_o(:,:,jj),ges_t2m(:,:,jj)+delta_z*T_lapse,ges_ps(:,:,jj),lat2,lon2,1,ice,iderivative) + enddo + + call tintrp2a11(qg2m_o,qsges_o,dlat,dlon,dtime,hrdifsig,mype,nfldsig) + q_delta_terrain = (qsges/qsges_o - 1)*qob + qob = qob * ( qsges/qsges_o) + + !update the station elevation + data(istnelv,i) = data(izz,i) + + endif + ddiff=qob-qges ! Setup dynamic ob error specification for aircraft recon in hurricanes @@ -572,18 +628,22 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav endif errorx =max(small1,errorx) - ! Adjust observation error to reflect the size of the residual. ! If extrapolation occurred, then further adjust error according to ! amount of extrapolation. - rlow=max(sfcchk-dpres,zero) + if (.not. (hofx_2m_sfcfile .and. landsfctype) ) then + rlow=max(sfcchk-dpres,zero) ! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] - if(l_sfcobserror_ramp_q) then - ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)*0.001_r_kind + if(l_sfcobserror_ramp_q) then + ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)*0.001_r_kind + else + ramp=rlow + endif else - ramp=rlow + rlow = zero + ramp = zero endif rhgh=max(dpres-r0_001-rsig,zero) @@ -594,7 +654,20 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if(rhgh/=zero) awork(3) = awork(3) + one end if - ratio_errors=error*qsges/(errorx+1.0e6_r_kind*rhgh+r8*ramp) +! inflate error for uncertainty in the terrain adjustment + lapse_error = 0. + if ( hofx_2m_sfcfile .and. landsfctype) then + if (abs(delta_z)max_delta_z do not assim. + ! inflate obs error to account for error in lapse_rate + ! also include some representativity error here (assuming + ! delta_z ~ heterogeneity) + lapse_error = abs(lapse_error_frac*q_delta_terrain) + else + muse(i)=.false. + endif + endif + + ratio_errors=error*qsges/(errorx+1.0e6_r_kind*rhgh+r8*ramp + lapse_error) ! Check to see if observations is above the top of the model (regional mode) if (dpres > rsig) ratio_errors=zero @@ -618,7 +691,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav dhx_dx%val(2) = delz ! weight for iz+1's level endif -! Interpolate 2-m q to obs locations/times +! i_use_2mq4b: Interpolate 2-m q to obs locations/times if(i_use_2mq4b>0 .and. itype > 179 .and. itype < 190 .and. .not.twodvar_regional)then if(i_coastline==2 .or. i_coastline==3) then @@ -643,7 +716,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call stop2(100) endif ddiff=qob-qges - endif + endif ! i_use_2mq4b ! If requested, setup for single obs test. @@ -943,7 +1016,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head => null() ENDDO - endif ! 181,183,187 + endif ! l_pbl_pseudo_itype !!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!! ! End of loop over observations @@ -1025,7 +1098,7 @@ subroutine init_vars_ call stop2(999) endif ! get q2m ... - if (i_use_2mq4b>0) then + if (i_use_2mq4b>0 .or. hofx_2m_sfcfile) then varname='q2m' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) if (istatus==0) then @@ -1044,6 +1117,25 @@ subroutine init_vars_ call stop2(999) endif endif ! i_use_2mq4b + if (hofx_2m_sfcfile) then + varname='t2m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_t2m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_t2m(size(rank2,1),size(rank2,2),nfldsig)) + ges_t2m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_t2m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + endif ! hofx_2m_sfcfile ! get q ... varname='q' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) @@ -1272,8 +1364,10 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) +! this is the obs height after being interpolated to the model (=model height) call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) call nc_diag_metadata("Pressure", sngl(presq) ) +! this is the original obs height (= stn elevation, before being interpolated) call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) call nc_diag_metadata("Time", sngl(dtime-time_offset)) call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) @@ -1392,6 +1486,7 @@ end subroutine contents_netcdf_diagp_ subroutine final_vars_ if(allocated(ges_q2m)) deallocate(ges_q2m) + if(allocated(ges_t2m)) deallocate(ges_t2m) if(allocated(ges_q )) deallocate(ges_q ) if(allocated(ges_ps)) deallocate(ges_ps) end subroutine final_vars_ diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 022c0ff93a..eea6d1e1f5 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -404,7 +404,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& real(r_kind),dimension(nchanl):: tcc real(r_kind) :: ptau5deriv, ptau5derivmax real(r_kind) :: clw_guess,clw_guess_retrieval,ciw_guess,rain_guess,snow_guess,clw_avg - real(r_kind) :: tnoise_save real(r_kind),dimension(:), allocatable :: rsqrtinv real(r_kind),dimension(:), allocatable :: rinvdiag real(r_kind),dimension(nchanl) :: abi2km_bc @@ -422,10 +421,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& integer(i_kind),allocatable,dimension(:) :: sc_index integer(i_kind) :: state_ind, nind, nnz - logical channel_passive + logical,dimension(jpch_rad) :: channel_passive logical,dimension(nobs):: luse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - integer(i_kind):: nperobs + integer(i_kind):: nperobs,ncr character(10) filex character(12) string @@ -542,6 +541,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& jc=0 do j=1,jpch_rad + channel_passive(j)=iuse_rad(j)==-1 .or. iuse_rad(j)==0 if(isis == nusis(j))then jc=jc+1 if(jc > nchanl)then @@ -562,10 +562,9 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! ! Set error instrument channels tnoise(jc)=varch(j) - channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 - if (iuse_rad(j)< -1 .or. (channel_passive .and. & + if (iuse_rad(j)< -1 .or. (channel_passive(j) .and. & .not.rad_diagsave)) tnoise(jc)=r1e10 - if (passive_bc .and. channel_passive) tnoise(jc)=varch(j) + if (passive_bc .and. channel_passive(j)) tnoise(jc)=varch(j) if (iuse_rad(j)>0) l_may_be_passive=.true. if (tnoise(jc) < 1.e4_r_kind) toss = .false. @@ -849,25 +848,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& iinstr=getindex(idnames,trim(covtype)) endif endif - do jc=1,nchanl - j=ich(jc) - - tnoise(jc)=varch(j) - - if(sea .and. (varch_sea(j)>zero)) tnoise(jc)=varch_sea(j) - if(land .and. (varch_land(j)>zero)) tnoise(jc)=varch_land(j) - if(ice .and. (varch_ice(j)>zero)) tnoise(jc)=varch_ice(j) - if(snow .and. (varch_snow(j)>zero)) tnoise(jc)=varch_snow(j) - if(mixed .and. (varch_mixed(j)>zero)) tnoise(jc)=varch_mixed(j) - tnoise_save = tnoise(jc) - - channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 - if (iuse_rad(j)< -1 .or. (channel_passive .and. & - .not.rad_diagsave)) tnoise(jc)=r1e10 - if (passive_bc .and. channel_passive) tnoise(jc)=tnoise_save - if (tnoise(jc) < 1.e4_r_kind) toss = .false. - end do - ! Count data of different surface types if(luse(n))then if (mixed) then @@ -888,9 +868,30 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif endif + do jc=1,nchanl + j=ich(jc) + + tnoise(jc)=varch(j) + + if(mixed .and. (varch_mixed(j)>zero)) then + tnoise(jc)=varch_mixed(j) + else if(snow .and. (varch_snow(j)>zero)) then + tnoise(jc)=varch_snow(j) + else if(ice .and. (varch_ice(j)>zero)) then + tnoise(jc)=varch_ice(j) + else if(land .and. (varch_land(j)>zero)) then + tnoise(jc)=varch_land(j) + else if(sea .and. (varch_sea(j)>zero)) then + tnoise(jc)=varch_sea(j) + end if + + if (.not. (passive_bc .and. channel_passive(j))) then + if (iuse_rad(j)< -1 .or. (channel_passive(j) .and. & + .not.rad_diagsave)) tnoise(jc)=r1e10 + end if + ! Load channel data into work array. - do i = 1,nchanl - tb_obs(i) = data_s(i+nreal,n) + tb_obs(jc) = data_s(jc+nreal,n) end do @@ -998,10 +999,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& tsavg5=tsavg5+dtsavg endif +! Compute microwave cloud liquid water or graupel water path for bias correction and QC. + if (adp_anglebc) then ! If using adaptive angle dependent bias correction, update the predicctors ! for this part of bias correction. The AMSUA cloud liquid water algorithm ! uses total angle dependent bias correction for channels 1 and 2 - if (adp_anglebc) then do i=1,nchanl mm=ich(i) if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then @@ -1020,8 +1022,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if end do end if - -! Compute microwave cloud liquid water or graupel water path for bias correction and QC. +!***** clw_obs=zero clw_guess_retrieval=zero gwp=zero @@ -1058,10 +1059,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& id_qc(1:nchanl) = ifail_cloud_qc endif endif - endif ! Screening for cold-air outbreak area (only applied to MW for now) - if (cao_check .and. radmod%lprecip) then - if(microwave .and. sea) then + if (cao_check .and. radmod%lprecip) then if(radmod%lcloud_fwd) then cao_flag = (stability < 12.0_r_kind) .and. (hwp_ratio < half) .and. (tcwv < 8.0_r_kind) if (cao_flag) then ! remove all tropospheric channels @@ -1085,11 +1084,14 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero - cld_rbc_idx2=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) - !***** ! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES !***** @@ -1115,30 +1117,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& else pred(3,i) = clw_obs*cosza*cosza end if + if(radmod%lcloud_fwd .and. sea) pred(3,i ) = zero - - - ! Apply bias correction - - kmax(i) = 0 - if (lwrite_peakwt .or. passive_bc) then - ptau5derivmax = -9.9e31_r_kind -! maximum of weighting function is level at which transmittance -! (ptau5) is changing the fastest. This is used for the level -! assignment (needed for vertical localization). - weightmax(i) = zero - do k=2,nsig - ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ & - (log(prsltmp(k-1))-log(prsltmp(k))) ) - if (ptau5deriv > ptau5derivmax) then - ptau5derivmax = ptau5deriv - kmax(i) = k - weightmax(i) = r10*prsitmp(k) ! cb to mb. - end if - enddo - end if tlapchn(i)= (ptau5(2,i)-ptau5(1,i))*(tsavg5-tvp(2)) do k=2,nsig-1 @@ -1185,10 +1167,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 pred(:,i) = zero if (i>=2 .and. i<=4) then if (tb_obs(i) > 190.0_r_kind .and. tb_obs(i) < 300.0_r_kind) then @@ -1236,15 +1214,37 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& bias = bias+predbias(npred+2,i) cldeff_obs(i)=cldeff_obs(i) - bias ! observed cloud delta (bias corrected) endif + end do + kmax = 0 + if (lwrite_peakwt .or. passive_bc) then +!$omp parallel do schedule(dynamic,1) private(i,k,ptau5derivmax,ptau5deriv) + do i=1,nchanl + ptau5derivmax = -9.9e31_r_kind +! maximum of weighting function is level at which transmittance +! (ptau5) is changing the fastest. This is used for the level +! assignment (needed for vertical localization). + weightmax(i) = zero + do k=2,nsig + ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ & + (log(prsltmp(k-1))-log(prsltmp(k))) ) + if (ptau5deriv > ptau5derivmax) then + ptau5derivmax = ptau5deriv + kmax(i) = k + weightmax(i) = r10*prsitmp(k) ! cb to mb. + end if + enddo ! End of loop over channels - end do + end do + end if ! Compute retrieved microwave cloud liquid water and ! assign cld_rbc_idx for bias correction in allsky conditions cld_rbc_idx=one + cld_rbc_idx2=zero if (radmod%lcloud_fwd .and. radmod%ex_biascor .and. eff_area) then ierrret=0 +!$omp parallel do schedule(dynamic,1) private(i,mm,j) do i=1,nchanl mm=ich(i) tsim_bc(i)=tsim(i) @@ -1260,19 +1260,19 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& tsim_clr_bc(i)=tsim_clr_bc(i)+predbias(npred+2,i) end do - if(amsua.or.atms) call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) - if(gmi) then - call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) - call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) + if(amsua.or.atms) then + call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) + else if(gmi) then + call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) + call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) end if if (radmod%ex_obserr=='ex_obserr1') then call radiance_ex_biascor(radmod,nchanl,tsim_bc,tsavg5,zasat, & clw_guess_retrieval,clw_obs,cld_rbc_idx,ierrret) - end if -! if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested +! else if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested ! call radiance_ex_biascor(radmod,nchanl,cldeff_obs,cldeff_fg,cld_rbc_idx) ! end if - if (radmod%ex_obserr=='ex_obserr3') then + else if (radmod%ex_obserr=='ex_obserr3') then call radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld_rbc_idx) end if @@ -1325,17 +1325,17 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! Assign observation error for all-sky radiances if (radmod%lcloud_fwd .and. eff_area) then - if (radmod%ex_obserr=='ex_obserr1') & + if (radmod%ex_obserr=='ex_obserr1') then call radiance_ex_obserr(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) - if (radmod%ex_obserr=='ex_obserr3') & + else if (radmod%ex_obserr=='ex_obserr3') then call radiance_ex_obserr_gmi(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) + end if end if do i=1,nchanl mm=ich(i) - channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 - if(tnoise(i) < 1.e4_r_kind .or. (channel_passive .and. rad_diagsave) & - .or. (passive_bc .and. channel_passive))then + if(tnoise(i) < 1.e4_r_kind .or. (channel_passive(mm) .and. rad_diagsave) & + .or. (passive_bc .and. channel_passive(mm)))then varinv(i) = varinv(i)/error0(i)**2 errf(i) = error0(i) else @@ -1367,14 +1367,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr, & @@ -1466,14 +1462,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& else if (seviri .or. abi .or. ahi) then do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1492,9 +1484,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& do i=1,nchanl if((abi .or. ahi) .and. i/=2 .and. i/=3) then varinv(i)=zero - varinv_use(i)=zero - end if - if(seviri .and. i/=2) then + else if(seviri .and. i/=2) then varinv(i)=zero end if end do @@ -1502,15 +1492,15 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! ! additional qc for surface and chn7.3: use split window chns to remove opaque clouds - do i = 1,nchanl - if( (abi .or. ahi ).and. i/=2 .and. i/=3 ) then - if( varinv(i) > tiny_r_kind .and. & - (tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then - varinv(i)=zero - varinv_use(i)=zero - end if - end if - end do + if(abi .or. ahi) then + do i = 1,nchanl + if( i/=2 .and. i/=3 .and.varinv(i) > tiny_r_kind) then + if((tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then + varinv(i)=zero + end if + end if + end do + end if ! ! ---------- AVRHRR -------------- @@ -1528,14 +1518,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! channels with iuse_rad=-1 or 0 are used in cloud detection. do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1551,14 +1537,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! NOTE: use qc_avhrr for viirs qc do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1572,7 +1554,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& else if( ssmi .or. amsre .or. ssmis )then - frac_sea=data_s(ifrac_sea,n) if(amsre)then bearaz= (270._r_kind-data_s(ilazi_ang,n))*deg2rad sun_zenith=data_s(iszen_ang,n)*deg2rad @@ -1677,20 +1658,29 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end do if(amsua .or. atms .or. amsub .or. mhs .or. msu .or. hsb)then - if(amsua)nlev=6 - if(atms)nlev=7 - if(amsub .or. mhs)nlev=5 - if(hsb)nlev=4 - if(msu)nlev=4 + if(amsua)then + nlev=6 + else if(atms)then + nlev=7 + else if(amsub .or. mhs)then + nlev=5 + else if(hsb)then + nlev=4 + else if(msu)then + nlev=4 + end if kval=0 do i=2,nlev ! do i=1,nlev - channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 - if (varinv(i)=1) .or. & - (passive_bc .and. channel_passive))) then + mm=ich(i) + if (varinv(i)=1) .or. & + (passive_bc .and. channel_passive(mm)))) then kval=max(i-1,kval) - if(amsub .or. hsb .or. mhs)kval=nlev - if((amsua .or. atms) .and. i <= 3)kval = zero + if(amsub .or. hsb .or. mhs)then + kval=nlev + else if((amsua .or. atms) .and. i <= 3) then + kval = zero + end if end if end do if(kval > 0)then @@ -1701,60 +1691,55 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& if(amsua)then varinv(15)=zero if(id_qc(15) == igood_qc)id_qc(15)=ifail_interchan_qc - end if - if (atms) then + else if (atms) then varinv(16:18)=zero if(id_qc(16) == igood_qc)id_qc(16)=ifail_interchan_qc if(id_qc(17) == igood_qc)id_qc(17)=ifail_interchan_qc if(id_qc(18) == igood_qc)id_qc(18)=ifail_interchan_qc end if end if - end if - - if(mhs.or.amsub)then - do i = 1, nchanl - m = ich(i) - if(sea .and. isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det - endif - - if(sea .and. iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det - endif - if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det - endif - if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det - endif - enddo + if(mhs.or.amsub)then + do i = 1, nchanl + m = ich(i) + if(sea)then + if(isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det + + else if(iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det + endif + end if + if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det + + else if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det + endif + enddo + endif endif ! Screen out land surface types by channel. Flags are set in satinfo file. do i = 1, nchanl m = ich(i) - if(iwater_det(m) > 0 .and. sea) then + if(sea .and. iwater_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwater_det - endif - if(isnow_det(m) > 0 .and. snow) then + else if(snow .and. isnow_det(m) > 0 ) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_isnow_det - endif - if(mixed .and. imix_det(m) > 0) then + else if(mixed .and. imix_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_imix_det - endif - if(land .and. iland_det(m) > 0) then + else if(land .and. iland_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iland_det - endif - if(ice .and. iice_det(m) > 0) then + else if(ice .and. iice_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iice_det endif @@ -1769,39 +1754,36 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif endif - do i = 1,nchanl - ! Reject radiances for single radiance test - if (lsingleradob) then + if (lsingleradob) then + do i = 1,nchanl + ! if the channels are beyond 0.01 of oblat/oblon, specified ! in gsi namelist, or aren't of type 'oneob_type', reject if ( (abs(cenlat - oblat) > one/r100 .or. & abs(cenlon - oblon) > one/r100) .or. & obstype /= oneob_type ) then varinv(i) = zero - varinv_use(i) = zero if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range else ! if obchan <= zero, keep all footprints, if obchan > zero, ! keep only that which has channel obchan if (i /= obchan .and. obchan > zero) then varinv(i) = zero - varinv_use(i) = zero if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range endif endif !cenlat/lon - endif !lsingleradob - enddo + enddo + endif !lsingleradob diagadd=zero account_for_corr_obs = .false. - iii=0 varinv0=zero +!$omp parallel do schedule(dynamic,1) private(ii,m,k,asum) do ii=1,nchanl m=ich(ii) if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then - iii=iii+1 varinv0(ii)=varinv(ii) raterr2(ii)=error0(ii)**2*varinv0(ii) if (l_may_be_passive .and. .not. retrieval) then @@ -1815,10 +1797,17 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if end if enddo + iii=0 + do ii=1,nchanl + m=ich(ii) + if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then + iii=iii+1 + end if + end do err2 = one/error0**2 tbc0=tbc tb_obs0=tb_obs - wgtjo=varinv0 + wgtjo=varinv if (l_may_be_passive .and. .not. retrieval) then if(iii>0 .and. iinstr.ne.-1)then chan_count=(iii*(iii+1))/2 @@ -1845,18 +1834,14 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& m = ich(i) if(luse(n))then - drad = tbc0(i) - dradnob = tbcnob(i) + drad = tbc0(i)*cld_rbc_idx(i) + dradnob = tbcnob(i)*cld_rbc_idx(i) varrad = tbc(i)*varinv(i) stats(1,m) = stats(1,m) + one !number of obs -! stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor) -! stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2 -! stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution -! stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor) - stats(3,m) = stats(3,m) + drad*cld_rbc_idx(i) !obs-mod(w_biascor) - stats(4,m) = stats(4,m) + tbc0(i)*drad*cld_rbc_idx(i)!(obs-mod(w_biascor))**2 + stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor) + stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2 stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution - stats(6,m) = stats(6,m) + dradnob*cld_rbc_idx(i) !obs-mod(w/o_biascor) + stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor) if (account_for_corr_obs .and. (cor_opt ==1 .or. cor_opt ==2) ) then exp_arg = -half*tbc(i)**2 @@ -1890,7 +1875,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! summation of observation number if (newpc4pred) then - ostats(m) = ostats(m) + one*cld_rbc_idx(i) + ostats(m) = ostats(m) + cld_rbc_idx(i) end if end if @@ -1901,12 +1886,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! At the end of analysis, prepare for bias correction for monitored channels ! Only "good monitoring" obs are included in J_passive calculation. - channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 - if (passive_bc .and. (jiter>miter) .and. channel_passive) then + if (passive_bc .and. (jiter>miter) .and. channel_passive(m)) then ! summation of observation number, ! skip ostats accumulation for channels without coef. initialization if (newpc4pred .and. luse(n) .and. any(predx(:,m)/=zero)) then - ostats(m) = ostats(m) + one*cld_rbc_idx(i) + ostats(m) = ostats(m) + cld_rbc_idx(i) end if iccm=iccm+1 end if @@ -1952,7 +1936,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& my_head%raterr2(icc),my_head%pred(npred,icc), & my_head%dtb_dvar(nsigradjac,icc), & my_head%ich(icc),& - my_head%icx(icc)) + my_head%icx(icc),my_head%iccerr(icc)) if(luse_obsdiag)allocate(my_head%diags(icc)) call get_ij(mm1,slats,slons,my_head%ij,my_head%wij) @@ -2020,6 +2004,13 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if ! end of newpc4pred loop end if end do + ncr=0 + do ii=1,iii + my_head%iccerr(ii) = ncr + do mm=1,ii + ncr=ncr+1 + end do + end do my_head%nchan = iii ! profile observation count my_head%use_corr_obs=.false. @@ -2114,23 +2105,28 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& allocate(my_headm%res(iccm),my_headm%err2(iccm), & my_headm%raterr2(iccm),my_headm%pred(npred,iccm), & my_headm%ich(iccm), & - my_headm%icx(iccm)) + my_headm%icx(iccm),my_headm%iccerr(iccm)) my_headm%nchan = iccm ! profile observation count my_headm%time=dtime my_headm%luse=luse(n) my_headm%ich(:)=-1 iii=0 + ncr=0 do ii=1,nchanl m=ich(ii) - channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 - if (varinv(ii)>tiny_r_kind .and. channel_passive) then + if (varinv(ii)>tiny_r_kind .and. channel_passive(m)) then iii=iii+1 my_headm%res(iii)=tbc(ii) ! obs-ges innovation my_headm%err2(iii)=one/error0(ii)**2 ! 1/(obs error)**2 (original uninflated error) my_headm%raterr2(iii)=error0(ii)**2*varinv(ii) ! (original error)/(inflated error) my_headm%icx(iii)=m ! channel index + do mm=1,ii + ncr=ncr+1 + end do + + my_headm%iccerr(iii)=ncr ! channel index do k=1,npred my_headm%pred(k,iii)=pred(k,ii)*upd_pred(k)*max(cld_rbc_idx(ii),cld_rbc_idx2(ii)) end do diff --git a/src/gsi/setuprw.f90 b/src/gsi/setuprw.f90 index c32ea80ab7..2211ee6caa 100644 --- a/src/gsi/setuprw.f90 +++ b/src/gsi/setuprw.f90 @@ -114,7 +114,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa use obsmod, only: rmiss_single,lobsdiag_forenkf,& lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,& if_vterminal, ens_hx_dbz_cut, if_model_dbz, & - doradaroneob,oneobddiff,oneobvalue, if_vrobs_raw + doradaroneob,oneobddiff,oneobvalue, if_vrobs_raw, if_use_w_vr use obsmod, only: netcdf_diag, binary_diag, dirname,ianldate use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & nc_diag_write, nc_diag_data2d @@ -972,7 +972,7 @@ subroutine check_vars_ (proceed, include_w) call gsi_metguess_get ('var::v' , ivar, istatus ) proceed=proceed.and.ivar>0 call gsi_metguess_get ('var::w' , ivar, istatus ) - if (ivar>0) then + if (if_use_w_vr.and.ivar>0) then include_w=.true. if(if_vterminal)then if( .not. if_model_dbz ) then diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 815c16014d..a0710e8abb 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -54,11 +54,11 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav use gridmod, only: nsig,twodvar_regional,regional use gridmod, only: get_ijk,pt_ll - use jfunc, only: jiter,last,jiterstart,miter + use jfunc, only: jiter,last,jiterstart,miter,hofx_2m_sfcfile use guess_grids, only: nfldsig, hrdifsig,ges_lnprsl,& geop_hgtl,ges_tsen,pbl_height - use state_vectors, only: svars3d, levels + use state_vectors, only: svars3d, levels, ns3d, svars2d use constants, only: zero, one, four,t0c,rd_over_cp,three,rd_over_cp_mass,ten use constants, only: tiny_r_kind,half,two @@ -228,6 +228,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! for 3D-RTMA (if l_obsprvdiag is true). ! 2022-03-15 Hu change all th2 to t2m to indicate that 2m temperature ! is sensible instead of potentionl temperature +! 2023-03-21 Draper added option to interpolate screen-level T from model 2m output. +! (hofx_2m_sfcfile) ! ! !REMARKS: ! language: f90 @@ -309,7 +311,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav logical,dimension(nobs):: luse,muse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical sfctype + logical sfctype, landsfctype logical iqtflg logical aircraftobst logical duplogic @@ -342,6 +344,18 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav integer(i_kind):: ich0 type(obsLList),pointer,dimension(:):: thead + + real(r_kind) :: delta_z, lapse_error + real(r_kind), parameter :: T_lapse = -0.0045 ! standard lapse rate, K/m +! use 4.5 K/km, in place of more standard 6.5 K/km, following +! https://agupubs.onlinelibrary.wiley.com/doi/10.1029/2019EA000984 +! lapse_error_frac around 0.5 ~ 2K/km, from Figure 2 of above. + real(r_kind), parameter :: lapse_error_frac = 0.5 ! inflation factor for obs error when vertically interpolating + real(r_kind), parameter :: max_delta_z = 300. ! max. vertical mismatch allowed + +! CSD - move this to where the namelists are read in. + if (i_use_2mt4b>0) hofx_2m_sfcfile=.false. + thead => obsLL(:) save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf @@ -432,8 +446,11 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav hr_offset=min_offset/60.0_r_kind dup=one do k=1,nobs + ikx=nint(data(ikxx,k)) + itype=ictype(ikx) + landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 ) do l=k+1,nobs - if (twodvar_regional) then + if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then duplogic=data(ilat,k) == data(ilat,l) .and. & data(ilon,k) == data(ilon,l) .and. & data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & @@ -465,6 +482,10 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav end do ! Run a buddy-check +! Note: buddy check crashes for hofx_2m_sfcfile option. +! Ccurrent params have buddy radius of 108 km, max diff of 8 K. +! The gross error check removes O-F > 7., so this is probably removing +! most obs that fail the buddy check already if (twodvar_regional .and. buddycheck_t) call buddy_check_t(is,data,luse,mype,nele,nobs,muse,buddyuse) ! If requested, save select data for output to diagnostic file @@ -521,6 +542,10 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav rstation_id = data(id,i) prest=r10*exp(dpres) ! in mb sfctype=(itype>179.and.itype<190).or.(itype>=192.and.itype<=199) +! hofx_2m_sfcfile option to calculate hofx from 2m model output (rather than LML) +! is restricted to landsfctype only. GDAS assimilates 180 and 182 over ocean, +! should we also use 2m model output for the over-ocean obs? + landsfctype =( itype==181 .or. itype==183 .or. itype==187 ) iqtflg=nint(data(iqt,i)) == 0 var_jb=data(ijb,i) @@ -654,17 +679,22 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& nsig,mype,nfldsig) - drpx=zero - if(sfctype .and. .not.twodvar_regional) then - drpx=abs(one-((one/exp(dpres-log(psges))))**rd_over_cp)*t0c - end if + drpx = zero + if ( hofx_2m_sfcfile .and. landsfctype) then + dpres = one ! put obs at surface + else + if(sfctype .and. .not.twodvar_regional) then + drpx=abs(one-((one/exp(dpres-log(psges))))**rd_over_cp)*t0c + end if -! Put obs pressure in correct units to get grid coord. number - call grdcrd1(dpres,prsltmp(1),nsig,-1) +! Put obs pressure in correct units to get grid coord. number + call grdcrd1(dpres,prsltmp(1),nsig,-1) + endif ! Implementation of forward model ---------- - if(sfctype.and.sfcmodel) then +! SCENARIO 1: If obs is sfctype, and sfcmodel is requested. Outdated. + if(sfctype .and. sfcmodel) then tgges=data(iskint,i) roges=data(isfcr,i) @@ -694,8 +724,47 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav f10ges,u10ges,v10ges, t2ges, q2ges, regime, iqtflg) tges = t2ges +! SCENARIO 2: obs is sfctype, and hofx_2m_sfcfile scheme is on. +! 2m forecast has been read from the sfc guess files + elseif (landsfctype .and. hofx_2m_sfcfile ) then + +! mask: 0 - sea, 1 - land, 2-ice, >= 3 mixed +! for now, use only pure land + if (int(data(idomsfc,i)) .NE. 1 ) muse(i) = .false. + + call tintrp2a11(ges_t2m,tges2m,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + +! correct obs to model terrain height using a standard lapse rate. +! Later: look into updating with lapse-rate from the model (similar to gsd_terrain_match) + + delta_z = data(izz,i) - data(istnelv,i) + tob = tob + delta_z*T_lapse + !update the station elevation + data(istnelv,i) = data(izz,i) + + if(save_jacobian) then + t_ind = getindex(svars2d, 't2m') + if (t_ind < 0) then + print *, 'Error: no variable t2m in state vector.Exiting.' + call stop2(1300) + endif + dhx_dx%st_ind(1) = sum(levels(1:ns3d)) + t_ind + dhx_dx%end_ind(1) = sum(levels(1:ns3d)) + t_ind + dhx_dx%val(1) = one + dhx_dx%val(2) = zero ! in this case, there is no vertical interp + ! and nnz (=dim(dhx_dx%val)) should be one, + ! but nnz is a file attribute, so need to use + ! same value as for vertical profile obs. Get + ! around this by setting val(2) to zero. + endif + +! SCENARIO 3: obs is sfctype, and neither sfcmodel nor hofx_2m_sfcfile is chosen +! .or. obs is not sfctype. Interpoate hofx from model levels. else + if(iqtflg)then +! SCENARIO 3a: obs is a virtual temp. ! Interpolate guess tv to observation location and time call tintrp31(ges_tv,tges,dlat,dlon,dpres,dtime, & hrdifsig,mype,nfldsig) @@ -717,6 +786,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav dhx_dx%val(2) = delz ! weight for iz+1's level endif else +! SCENARIO 3b: obs is a sensible temp. ! Interpolate guess tsen to observation location and time call tintrp31(ges_tsen,tges,dlat,dlon,dpres,dtime, & hrdifsig,mype,nfldsig) @@ -739,6 +809,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav endif end if + +! SCENARIO 4: obs is sfctype, and i_use_2mt4b flag is on (turns on regional sfc DA) if(i_use_2mt4b>0 .and. sfctype) then if(i_coastline==1 .or. i_coastline==3) then @@ -773,17 +845,23 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call grdcrd1(sfcchk,prsltmp(1),nsig,-1) ! Check to see if observations is above the top of the model (regional mode) - if(sfctype)then + if(sfctype .and. .not. (hofx_2m_sfcfile .and. landsfctype) )then if(abs(dpres)>four) drpx=1.0e10_r_kind pres_diff=prest-r10*psges if (twodvar_regional .and. abs(pres_diff)>=r1000) drpx=1.0e10_r_kind end if - rlow=max(sfcchk-dpres,zero) -! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] - if(l_sfcobserror_ramp_t) then - ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind) + + if (.not. (hofx_2m_sfcfile .and. landsfctype) ) then + rlow=max(sfcchk-dpres,zero) +! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] + if(l_sfcobserror_ramp_t) then + ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind) + else + ramp=rlow + endif else - ramp=rlow + rlow = zero + ramp = zero endif rhgh=max(zero,dpres-rsigp-r0_001) @@ -795,12 +873,26 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if(rlow/=zero) awork(2) = awork(2) + one if(rhgh/=zero) awork(3) = awork(3) + one end if - - ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+r8*ramp) + +! inflate error for uncertainty in the terrain adjustment + lapse_error = 0. + if ( hofx_2m_sfcfile .and. landsfctype) then + if (abs(delta_z)max_delta_z do not assim. + ! inflate obs error to account for error in lapse_rate + ! also include some representativity error here (assuming + ! delta_z ~ heterogeneity) + lapse_error = abs(lapse_error_frac*T_lapse*delta_z) + else + muse(i)=.false. + endif + endif + + ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+r8*ramp + lapse_error) ! Compute innovation - if(i_use_2mt4b>0 .and. sfctype) then + if( (sfctype .and. i_use_2mt4b>0) .or. (hofx_2m_sfcfile .and. landsfctype) ) then ddiff = tob-tges2m + if (hofx_2m_sfcfile) tges=tges2m else ddiff = tob-tges endif @@ -1411,7 +1503,7 @@ subroutine init_vars_ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) endif - if(i_use_2mt4b>0) then + if(i_use_2mt4b>0 .or. hofx_2m_sfcfile) then ! get t2m ... varname='t2m' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) @@ -1430,6 +1522,7 @@ subroutine init_vars_ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) endif + ! get q2m ... varname='q2m' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) @@ -1676,8 +1769,10 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) +! this is the obs height after being interpolated to the model (=model height) call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) call nc_diag_metadata("Pressure", sngl(prest) ) +! this is the original obs height (= stn elevation, before being interpolated) call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) call nc_diag_metadata("Time", sngl(dtime-time_offset)) call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) @@ -1693,7 +1788,11 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - call nc_diag_metadata("Observation", sngl(data(itob,i)) ) + if (hofx_2m_sfcfile ) then + call nc_diag_metadata("Observation", sngl(tob) ) + else + call nc_diag_metadata("Observation", sngl(data(itob,i)) ) + endif call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(tob-tges) ) diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 174b6e695e..62b58a0485 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -219,7 +219,6 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! level; they are now loaded by ! aircraftinfo. ! 2020-05-04 wu - no rotate_wind for fv3_regional -! 2021-07-25 Genkova - write AMVQ in diagnostic files ! 2021-10-xx pondeca/morris/zhao - added observation provider/subprovider ! information in diagonostic file, which is used ! in offline observation quality control program (AutoObsQC) @@ -293,7 +292,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav integer(i_kind) ihgt,ier2,iuse,ilate,ilone integer(i_kind) izz,iprvd,isprvd integer(i_kind) idomsfc,isfcr,iskint,iff10 - integer(i_kind) ibb,ikk,ihil,idddd,iamvq + integer(i_kind) ibb,ikk,ihil,idddd integer(i_kind) num_bad_ikx,iprev_station @@ -384,9 +383,8 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav icat=24 ! index of data level category ijb=25 ! index of non linear qc parameter ihil=26 ! index of hilbert curve weight - iamvq=27 ! index of AMVQ - iptrbu=28 ! index of u perturbation - iptrbv=29 ! index of v perturbation + iptrbu=27 ! index of u perturbation + iptrbv=28 ! index of v perturbation mm1=mype+1 scale=one @@ -402,7 +400,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if(conv_diagsave)then ii=0 nchar=1 - ioff0=26 + ioff0=25 nreal=ioff0 if (lobsdiagsave) nreal=nreal+7*miter+2 if (twodvar_regional .or. l_obsprvdiag) then @@ -1254,7 +1252,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call vqc_setup(vals,ratio_errors,error,cvar,& cg_t,ibb,ikk,var_jb,rat_err2v,wgt,valqcv) rwgt = rwgt+0.5_r_kind*wgt/wgtlim - valqc=valqcu+valqcv + valqc=half*(valqcu+valqcv) ! Accumulate statistics for obs belonging to this task if (muse(i)) then @@ -1725,7 +1723,6 @@ subroutine contents_binary_diag_(udiag,vdiag) rdiagbuf(23,ii) = factw ! 10m wind reduction factor rdiagbuf(24,ii) = 1.e+10_r_single ! u spread (filled in by EnKF) rdiagbuf(25,ii) = 1.e+10_r_single ! v spread (filled in by EnKF) - rdiagbuf(26,ii) = data(iamvq,i) ! AMVQ mitigation flag for AMVs;only for GOES17,LHP issue ioff=ioff0 if (lobsdiagsave) then @@ -1812,8 +1809,6 @@ subroutine contents_netcdf_diag_(udiag,vdiag) call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - ! AMVQ Mitigated winds - call nc_diag_metadata("Mitigation_flag_AMVQ", sngl(data(iamvq,i)) ) call nc_diag_metadata("Wind_Reduction_Factor_at_10m", sngl(factw) ) if (.not. regional .or. fv3_regional) then diff --git a/src/gsi/state_vectors.f90 b/src/gsi/state_vectors.f90 index 711043fa57..df332303b0 100644 --- a/src/gsi/state_vectors.f90 +++ b/src/gsi/state_vectors.f90 @@ -62,7 +62,7 @@ module state_vectors use GSI_BundleMod, only : GSI_GridCreate use mpeu_util, only: gettablesize -use mpeu_util, only: gettable +use mpeu_util, only: gettable,getindex implicit none @@ -83,6 +83,8 @@ module state_vectors public svars public levels public ns2d,ns3d,nsdim + public qgpresent,qspresent,qrpresent,qipresent,qlpresent + public cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent ! State vector definition ! Could contain model state fields plus other fields required @@ -101,6 +103,8 @@ module state_vectors character(len=max_varname_length),allocatable,dimension(:) :: svars2d integer(i_kind) ,allocatable,dimension(:) :: levels +logical qgpresent,qspresent,qrpresent,qipresent,qlpresent +logical cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent ! ---------------------------------------------------------------------- INTERFACE PRT_STATE_NORMS @@ -245,6 +249,18 @@ subroutine init_anasv write(6,*) myname_,': 3D-STATE VARIABLES ', svars3d write(6,*) myname_,': ALL STATE VARIABLES ', svars end if +qgpresent=getindex(svars3d,'qg')>0 +qspresent=getindex(svars3d,'qs')>0 +qrpresent=getindex(svars3d,'qr')>0 +qipresent=getindex(svars3d,'qi')>0 +qlpresent=getindex(svars3d,'ql')>0 +cldchpresent=getindex(svars2d,'cldch')>0 +lcbaspresent=getindex(svars2d,'lcbas')>0 +howvpresent=getindex(svars2d,'howv')>0 +wspd10mpresent=getindex(svars2d,'wspd10m')>0 +pblhpresent=getindex(svars2d,'pblh')>0 +vispresent=getindex(svars2d,'vis')>0 +gustpresent=getindex(svars2d,'gust')>0 end subroutine init_anasv subroutine final_anasv @@ -370,7 +386,7 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) ! local variables real(r_kind),allocatable,dimension(:) :: zloc,nloc real(r_kind),allocatable,dimension(:,:) :: zall,nall - integer(i_kind) :: i,ii + integer(i_kind) :: i pmin=zero pmax=zero @@ -383,59 +399,32 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) zloc=zero ! Independent part of vector -! Sum - ii=0 +! Sum,Max,Min and number of points +!$omp parallel do schedule(dynamic,1) !private(i) do i = 1,ns3d - ii=ii+1 if(xst%r3(i)%mykind==r_single)then - zloc(ii)= sum_mask(xst%r3(i)%qr4,ihalo=1) + zloc(i)= sum_mask(xst%r3(i)%qr4,ihalo=1) + zloc(nvars+i)= minval(xst%r3(i)%qr4) + zloc(2*nvars+i)= maxval(xst%r3(i)%qr4) else - zloc(ii)= sum_mask(xst%r3(i)%q,ihalo=1) + zloc(i)= sum_mask(xst%r3(i)%q,ihalo=1) + zloc(nvars+i)= minval(xst%r3(i)%q) + zloc(2*nvars+i)= maxval(xst%r3(i)%q) endif - nloc(ii) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields + nloc(i) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields enddo +!$omp parallel do schedule(dynamic,1) !private(i) do i = 1,ns2d - ii=ii+1 if(xst%r2(i)%mykind==r_single)then - zloc(ii)= sum_mask(xst%r2(i)%qr4,ihalo=1) + zloc(ns3d+i)= sum_mask(xst%r2(i)%qr4,ihalo=1) + zloc(nvars+ns3d+i)= minval(xst%r2(i)%qr4) + zloc(2*nvars+ns3d+i)= maxval(xst%r2(i)%qr4) else - zloc(ii)= sum_mask(xst%r2(i)%q,ihalo=1) - endif - nloc(ii) = real((lat2-2)*(lon2-2), r_kind) ! dim of 2d fields - enddo -! Min - do i = 1,ns3d - ii=ii+1 - if(xst%r3(i)%mykind==r_single)then - zloc(ii)= minval(xst%r3(i)%qr4) - else - zloc(ii)= minval(xst%r3(i)%q) - endif - enddo - do i = 1,ns2d - ii=ii+1 - if(xst%r2(i)%mykind==r_single)then - zloc(ii)= minval(xst%r2(i)%qr4) - else - zloc(ii)= minval(xst%r2(i)%q) - endif - enddo -! Max - do i = 1,ns3d - ii=ii+1 - if(xst%r3(i)%mykind==r_single)then - zloc(ii)= maxval(xst%r3(i)%qr4) - else - zloc(ii)= maxval(xst%r3(i)%q) - endif - enddo - do i = 1,ns2d - ii=ii+1 - if(xst%r2(i)%mykind==r_single)then - zloc(ii)= maxval(xst%r2(i)%qr4) - else - zloc(ii)= maxval(xst%r2(i)%q) + zloc(ns3d+i)= sum_mask(xst%r2(i)%q,ihalo=1) + zloc(nvars+ns3d+i)= minval(xst%r2(i)%q) + zloc(2*nvars+ns3d+i)= maxval(xst%r2(i)%q) endif + nloc(ns3d+i) = real((lat2-2)*(lon2-2), r_kind) ! dim of 2d fields enddo ! Gather contributions @@ -444,20 +433,12 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) call mpi_allgather(nloc,size(nloc),mpi_rtype, & & nall,size(nloc),mpi_rtype, mpi_comm_world,ierror) - ii=0 - do i=1,ns3d - ii=ii+1 - psum(ii)=SUM(zall(ii,:)) - pnum(ii)=SUM(nall(ii,:)) - enddo - do i=1,ns2d - ii=ii+1 - psum(ii)=SUM(zall(ii,:)) - pnum(ii)=SUM(nall(ii,:)) - enddo - do ii=1,nvars - pmin(ii)=MINVAL(zall( nvars+ii,:)) - pmax(ii)=MAXVAL(zall(2*nvars+ii,:)) +!$omp parallel do schedule(dynamic,1) !private(i) + do i=1,nvars + psum(i)=SUM(zall(i,:)) + pnum(i)=SUM(nall(i,:)) + pmin(i)=MINVAL(zall( nvars+i,:)) + pmax(i)=MAXVAL(zall(2*nvars+i,:)) enddo ! Release work space diff --git a/src/gsi/statsconv.f90 b/src/gsi/statsconv.f90 index 7ddb7dea04..a01675d8d0 100644 --- a/src/gsi/statsconv.f90 +++ b/src/gsi/statsconv.f90 @@ -154,20 +154,6 @@ subroutine statsconv(mype,& ! Summary report for winds if(mype==mype_uv) then -! Open output file so as to point to correct position in output file - if(first)then - open(iout_uv) - else - open(iout_uv,position='append') - end if - - -! Compute and write counts, penalties, and ratio of penalty -! to data counts for each model level - numssm=nint(awork(6,i_uv)); numgross=nint(awork(4,i_uv)) - umplty=zero; vmplty=zero; uvqcplty=zero ; ntot=0; - tu=zero; tv=zero ; tuv=zero - tssm=zero ; qctssm=zero nread=0 nkeep=0 nreadspd=0 @@ -181,85 +167,92 @@ subroutine statsconv(mype,& nkeepspd=nkeepspd+ndata(i,3) end if end do - if(nkeep > 0 .or. nkeepspd > 0)then -! Write header information - mesage='current vfit of wind data, ranges in m/s$' + if(nread > 0 .or. nreadspd > 0)then +! Open output file so as to point to correct position in output file + if(first)then + open(iout_uv) + else + open(iout_uv,position='append') + end if -! Call routine to compute and write count, rms, and penalty information - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'spd' .or. trim(ioctype(j)) == 'uv' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_uv,pflag) - numlow = nint(awork(2,i_uv)) - numhgh = nint(awork(3,i_uv)) - write(iout_uv,900) 'wind',numhgh,numlow - numfailqc=nint(awork(21,i_uv)) -! keep a seperate record of numfailqc for ssmi wind speeds - numfailqc_ssmi=nint(awork(61,i_uv)) - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_uv)) - rat1=zero - rat2=zero - if(num(k) > 0)then - rat1=awork(4*nsig+k+100,i_uv)/float(num(k)) - rat2=awork(5*nsig+k+100,i_uv)/float(num(k)) + +! Compute and write counts, penalties, and ratio of penalty +! to data counts for each model level + numssm=nint(awork(6,i_uv)); numgross=nint(awork(4,i_uv)) + umplty=zero; vmplty=zero; uvqcplty=zero ; ntot=0; + tu=zero; tv=zero ; tuv=zero + tssm=zero ; qctssm=zero + if(nkeep > 0 .or. nkeepspd > 0)then +! Write header information + mesage='current vfit of wind data, ranges in m/s$' + +! Call routine to compute and write count, rms, and penalty information + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'spd' .or. trim(ioctype(j)) == 'uv' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_uv,pflag) + numlow = nint(awork(2,i_uv)) + numhgh = nint(awork(3,i_uv)) + write(iout_uv,900) 'wind',numhgh,numlow + numfailqc=nint(awork(21,i_uv)) +! keep a seperate record of numfailqc for ssmi wind speeds + numfailqc_ssmi=nint(awork(61,i_uv)) + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_uv)) + rat1=zero + rat2=zero + if(num(k) > 0)then + rat1=awork(4*nsig+k+100,i_uv)/float(num(k)) + rat2=awork(5*nsig+k+100,i_uv)/float(num(k)) + end if + umplty=umplty+awork(4*nsig+k+100,i_uv) + vmplty=vmplty+awork(5*nsig+k+100,i_uv) + ntot=ntot+num(k) + write(iout_uv,241) 'w',num(k),k,awork(4*nsig+k+100,i_uv),& + awork(5*nsig+k+100,i_uv),rat1,rat2 + end do + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_uv)) + rat1=zero + rat3=zero + if(num(k) > 0)then + rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/float(num(k)) + rat3=awork(3*nsig+k+100,i_uv)/float(num(k)) + end if + uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv) + write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), & + awork(3*nsig+k+100,i_uv),rat1,rat3 + end do + +! Write statistics gross checks + write(iout_uv,920)' number ssm/i winds that fail nonlinear qc =',numfailqc_ssmi + write(iout_uv,925) 'wind',numgross,numfailqc +! Write statistics regarding penalties + if(ntot > 0)then + tu=umplty/float(ntot) + tv=vmplty/float(ntot) + tuv=uvqcplty/float(ntot) end if - umplty=umplty+awork(4*nsig+k+100,i_uv) - vmplty=vmplty+awork(5*nsig+k+100,i_uv) - ntot=ntot+num(k) - write(iout_uv,241) 'w',num(k),k,awork(4*nsig+k+100,i_uv),& - awork(5*nsig+k+100,i_uv),rat1,rat2 - end do - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_uv)) - rat1=zero - rat3=zero - if(num(k) > 0)then - rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/float(num(k)) - rat3=awork(3*nsig+k+100,i_uv)/float(num(k)) + if(numssm > 0)then + tssm=awork(5,i_uv)/awork(6,i_uv) + qctssm=awork(22,i_uv)/awork(6,i_uv) end if - uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv) - write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), & - awork(3*nsig+k+100,i_uv),rat1,rat3 - end do - -! Write statistics gross checks - write(iout_uv,920)' number ssm/i winds that fail nonlinear qc =',numfailqc_ssmi - write(iout_uv,925) 'wind',numgross,numfailqc -! Write statistics regarding penalties - if(ntot > 0)then - tu=umplty/float(ntot) - tv=vmplty/float(ntot) - tuv=uvqcplty/float(ntot) end if - if(numssm > 0)then - tssm=awork(5,i_uv)/awork(6,i_uv) - qctssm=awork(22,i_uv)/awork(6,i_uv) - end if - end if - write(iout_uv,949) 'u',ntot,umplty,tu - write(iout_uv,949) 'v',ntot,vmplty,tv - write(iout_uv,950) 'uv',jiter,nread,nkeep,ntot*2 - write(iout_uv,951) 'uv',umplty+vmplty,uvqcplty,tu+tv,tuv - write(iout_uv,950) 'spd',jiter,nreadspd,nkeepspd,numssm - write(iout_uv,951) 'spd',awork(5,i_uv),awork(22,i_uv),tssm,qctssm + write(iout_uv,949) 'u',ntot,umplty,tu + write(iout_uv,949) 'v',ntot,vmplty,tv + write(iout_uv,950) 'uv',jiter,nread,nkeep,ntot*2 + write(iout_uv,951) 'uv',umplty+vmplty,uvqcplty,tu+tv,tuv + write(iout_uv,950) 'spd',jiter,nreadspd,nkeepspd,numssm + write(iout_uv,951) 'spd',awork(5,i_uv),awork(22,i_uv),tssm,qctssm ! Close unit receiving summary output - close(iout_uv) + close(iout_uv) + end if end if ! Summary report for gps if (mype==mype_gps)then - if(first)then - open(iout_gps) - else - open(iout_gps,position='append') - end if - - - gpsmplty=zero; gpsqcplty=zero ; ntot=0 - tgps=zero ; qctgps=zero nread=0 nkeep=0 ctype=' ' @@ -270,67 +263,64 @@ subroutine statsconv(mype,& ctype=dtype(i) end if end do - if(nkeep > 0)then - mesage='current fit of gps data in fractional difference$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'gps' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_gps,pflag) - do k=1,nsig - num(k)=nint(awork(5*nsig+k+100,i_gps)) - rat=zero - rat3=zero - if(num(k)>0) then - rat=awork(6*nsig+k+100,i_gps)/float(num(k)) - rat3=awork(3*nsig+k+100,i_gps)/float(num(k)) - end if - ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps) - gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps) - write(iout_gps,240)'gps',num(k),k,awork(6*nsig+k+100,i_gps), & - awork(3*nsig+k+100,i_gps),rat,rat3 - end do - numgross=nint(awork(4,i_gps)) - numfailqc=nint(awork(21,i_gps)) - numfail1_gps=nint(awork(22,i_gps)) - numfail2_gps=nint(awork(23,i_gps)) - numfail3_gps=nint(awork(24,i_gps)) - write(iout_gps,925)'gps',numgross,numfailqc - write(iout_gps,920)' number of gps obs failed stats qc in NH =',numfail1_gps - write(iout_gps,920)' number of gps obs failed stats qc in SH =',numfail2_gps - write(iout_gps,920)' number of gps obs failed stats qc in TR =',numfail3_gps - - numlow = nint(awork(2,i_gps)) - numhgh = nint(awork(3,i_gps)) - write(iout_gps,900) 'gps',numhgh,numlow - if(ntot > 0) then - tgps=gpsmplty/ntot - qctgps=gpsqcplty/ntot - endif - end if + if(nread > 0)then + if(first)then + open(iout_gps) + else + open(iout_gps,position='append') + end if - write(iout_gps,950) ctype,jiter,nread,nkeep,ntot - write(iout_gps,951) ctype,gpsmplty,gpsqcplty,tgps,qctgps - close(iout_gps) - endif + gpsmplty=zero; gpsqcplty=zero ; ntot=0 + tgps=zero ; qctgps=zero + if(nkeep > 0)then + mesage='current fit of gps data in fractional difference$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'gps' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_gps,pflag) + do k=1,nsig + num(k)=nint(awork(5*nsig+k+100,i_gps)) + rat=zero + rat3=zero + if(num(k)>0) then + rat=awork(6*nsig+k+100,i_gps)/float(num(k)) + rat3=awork(3*nsig+k+100,i_gps)/float(num(k)) + end if + ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps) + gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps) + write(iout_gps,240)'gps',num(k),k,awork(6*nsig+k+100,i_gps), & + awork(3*nsig+k+100,i_gps),rat,rat3 + end do + numgross=nint(awork(4,i_gps)) + numfailqc=nint(awork(21,i_gps)) + numfail1_gps=nint(awork(22,i_gps)) + numfail2_gps=nint(awork(23,i_gps)) + numfail3_gps=nint(awork(24,i_gps)) + write(iout_gps,925)'gps',numgross,numfailqc + write(iout_gps,920)' number of gps obs failed stats qc in NH =',numfail1_gps + write(iout_gps,920)' number of gps obs failed stats qc in SH =',numfail2_gps + write(iout_gps,920)' number of gps obs failed stats qc in TR =',numfail3_gps + + numlow = nint(awork(2,i_gps)) + numhgh = nint(awork(3,i_gps)) + write(iout_gps,900) 'gps',numhgh,numlow + if(ntot > 0) then + tgps=gpsmplty/ntot + qctgps=gpsqcplty/ntot + endif + end if + write(iout_gps,950) ctype,jiter,nread,nkeep,ntot + write(iout_gps,951) ctype,gpsmplty,gpsqcplty,tgps,qctgps -! Summary report for specific humidity - if(mype==mype_q) then - if(first)then - open(iout_q) - else - open(iout_q,position='append') + close(iout_gps) end if + endif - mesage='current fit of q data, units in per-cent of guess q-sat$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'q' - end do - call dtast(bwork,npres_print,pbotq,ptopq,mesage,jiter,iout_q,pflag) - qmplty=zero; qqcplty=zero ; ntot=0 - tq=zero ; qctq=zero +! Summary report for specific humidity + if(mype==mype_q) then nread=0 nkeep=0 do i=1,ndat @@ -339,53 +329,61 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - do k=1,nsig - num(k)=nint(awork(k+6*nsig+100,i_q)) - rat=zero - rat3=zero - if(num(k) > 0)then - rat=awork(5*nsig+k+100,i_q)/float(num(k)) - rat3=awork(3*nsig+k+100,i_q)/float(num(k)) - end if - qmplty=qmplty+awork(5*nsig+k+100,i_q) - qqcplty=qqcplty+awork(3*nsig+k+100,i_q) - ntot=ntot+num(k) - write(iout_q,240) 'q',num(k),k,awork(5*nsig+k+100,i_q), & - awork(3*nsig+k+100,i_q),rat,rat3 + if(nread > 0)then + if(first)then + open(iout_q) + else + open(iout_q,position='append') + end if + + mesage='current fit of q data, units in per-cent of guess q-sat$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'q' end do - grsmlt=five - numgrsq=nint(awork(4,i_q)) - numfailqc=nint(awork(21,i_q)) - write(iout_q,924)' (scaled as precent of guess specific humidity)' - write(iout_q,925) 'q',numgrsq,numfailqc - write(iout_q,975) grsmlt,'q',awork(5,i_q) - numlow = nint(awork(2,i_q)) - numhgh = nint(awork(3,i_q)) - write(iout_q,900) 'q',numhgh,numlow - if(ntot > 0) then - tq=qmplty/float(ntot) - qctq=qqcplty/float(ntot) + call dtast(bwork,npres_print,pbotq,ptopq,mesage,jiter,iout_q,pflag) + + qmplty=zero; qqcplty=zero ; ntot=0 + tq=zero ; qctq=zero + if(nkeep > 0)then + do k=1,nsig + num(k)=nint(awork(k+6*nsig+100,i_q)) + rat=zero + rat3=zero + if(num(k) > 0)then + rat=awork(5*nsig+k+100,i_q)/float(num(k)) + rat3=awork(3*nsig+k+100,i_q)/float(num(k)) + end if + qmplty=qmplty+awork(5*nsig+k+100,i_q) + qqcplty=qqcplty+awork(3*nsig+k+100,i_q) + ntot=ntot+num(k) + write(iout_q,240) 'q',num(k),k,awork(5*nsig+k+100,i_q), & + awork(3*nsig+k+100,i_q),rat,rat3 + end do + grsmlt=five + numgrsq=nint(awork(4,i_q)) + numfailqc=nint(awork(21,i_q)) + write(iout_q,924)' (scaled as precent of guess specific humidity)' + write(iout_q,925) 'q',numgrsq,numfailqc + write(iout_q,975) grsmlt,'q',awork(5,i_q) + numlow = nint(awork(2,i_q)) + numhgh = nint(awork(3,i_q)) + write(iout_q,900) 'q',numhgh,numlow + if(ntot > 0) then + tq=qmplty/float(ntot) + qctq=qqcplty/float(ntot) + end if end if - end if - write(iout_q,950) 'q',jiter,nread,nkeep,ntot - write(iout_q,951) 'q',qmplty,qqcplty,tq,qctq + write(iout_q,950) 'q',jiter,nread,nkeep,ntot + write(iout_q,951) 'q',qmplty,qqcplty,tq,qctq - close(iout_q) + close(iout_q) + end if end if ! Summary report for surface pressure if(mype==mype_ps) then - if(first)then - open(iout_ps) - else - open(iout_ps,position='append') - end if - - nump=nint(awork(5,i_ps)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -394,40 +392,42 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of surface pressure data, ranges in mb$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'ps' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_ps,pflag) + if(nread > 0)then + if(first)then + open(iout_ps) + else + open(iout_ps,position='append') + end if + + nump=nint(awork(5,i_ps)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of surface pressure data, ranges in mb$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'ps' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_ps,pflag) - numgross=nint(awork(6,i_ps)) - numfailqc=nint(awork(21,i_ps)) - write(iout_ps,925) 'psfc',numgross,numfailqc - if(nump > 0)then - pw=awork(4,i_ps)/float(nump) - pw3=awork(22,i_ps)/float(nump) + numgross=nint(awork(6,i_ps)) + numfailqc=nint(awork(21,i_ps)) + write(iout_ps,925) 'psfc',numgross,numfailqc + if(nump > 0)then + pw=awork(4,i_ps)/float(nump) + pw3=awork(22,i_ps)/float(nump) + end if end if - end if - write(iout_ps,950) 'psfc',jiter,nread,nkeep,nump - write(iout_ps,951) 'psfc',awork(4,i_ps),awork(22,i_ps),pw,pw3 + write(iout_ps,950) 'psfc',jiter,nread,nkeep,nump + write(iout_ps,951) 'psfc',awork(4,i_ps),awork(22,i_ps),pw,pw3 - close(iout_ps) + close(iout_ps) + end if end if ! Summary report for total precipitable water if(mype==mype_pw) then - if(first)then - open(iout_pw) - else - open(iout_pw,position='append') - end if - - nsuperp=nint(awork(4,i_pw)) - tpw=zero ; tpw3=zero nread=0 nkeep=0 do i=1,ndat @@ -436,41 +436,42 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of precip. water data, ranges in mm$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pw' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pw,pflag) - - numgrspw=nint(awork(6,i_pw)) - numfailqc=nint(awork(21,i_pw)) - grsmlt=three - tpw=zero - tpw3=zero - if(nsuperp > 0)then - tpw=awork(5,i_pw)/nsuperp - tpw3=awork(22,i_pw)/nsuperp - end if - write(iout_pw,925) 'p.w.',numgrspw,numfailqc - write(iout_pw,975) grsmlt,'p.w.',awork(7,i_pw) - end if - write(iout_pw,950) 'pw',jiter,nread,nkeep,nsuperp - write(iout_pw,951) 'pw',awork(5,i_pw),awork(22,i_pw),tpw,tpw3 + if(nread > 0)then + if(first)then + open(iout_pw) + else + open(iout_pw,position='append') + end if + tpw=zero ; tpw3=zero + if(nkeep > 0)then + mesage='current fit of precip. water data, ranges in mm$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pw' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pw,pflag) + + numgrspw=nint(awork(6,i_pw)) + numfailqc=nint(awork(21,i_pw)) + grsmlt=three + tpw=zero + tpw3=zero + nsuperp=nint(awork(4,i_pw)) + if(nsuperp > 0)then + tpw=awork(5,i_pw)/nsuperp + tpw3=awork(22,i_pw)/nsuperp + end if + write(iout_pw,925) 'p.w.',numgrspw,numfailqc + write(iout_pw,975) grsmlt,'p.w.',awork(7,i_pw) + end if + write(iout_pw,950) 'pw',jiter,nread,nkeep,nsuperp + write(iout_pw,951) 'pw',awork(5,i_pw),awork(22,i_pw),tpw,tpw3 - close(iout_pw) + close(iout_pw) + end if end if ! Summary report for conventional sst if(mype==mype_sst) then - if(first)then - open(iout_sst) - else - open(iout_sst,position='append') - end if - - numsst=nint(awork(5,i_sst)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -479,37 +480,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional sst data, ranges in C$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'sst' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_sst,pflag) + if(nread > 0)then + if(first)then + open(iout_sst) + else + open(iout_sst,position='append') + end if - numgross=nint(awork(6,i_sst)) - numfailqc=nint(awork(21,i_sst)) - if(numsst > 0)then - pw=awork(4,i_sst)/numsst - pw3=awork(22,i_sst)/numsst + numsst=nint(awork(5,i_sst)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional sst data, ranges in C$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'sst' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_sst,pflag) + + numgross=nint(awork(6,i_sst)) + numfailqc=nint(awork(21,i_sst)) + if(numsst > 0)then + pw=awork(4,i_sst)/numsst + pw3=awork(22,i_sst)/numsst + end if + write(iout_sst,925) 'sst',numgross,numfailqc end if - write(iout_sst,925) 'sst',numgross,numfailqc - end if - write(iout_sst,950) 'sst',jiter,nread,nkeep,numsst - write(iout_sst,951) 'sst',awork(4,i_sst),awork(22,i_sst),pw,pw3 + write(iout_sst,950) 'sst',jiter,nread,nkeep,numsst + write(iout_sst,951) 'sst',awork(4,i_sst),awork(22,i_sst),pw,pw3 - close(iout_sst) + close(iout_sst) + end if end if ! Summary report for conventional gust if(mype==mype_gust) then - if(first)then - open(iout_gust) - else - open(iout_gust,position='append') - end if - - numgust=nint(awork(5,i_gust)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -518,37 +521,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional gust data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'gust' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_gust,pflag) + if(nread > 0)then + if(first)then + open(iout_gust) + else + open(iout_gust,position='append') + end if - numgross=nint(awork(6,i_gust)) - numfailqc=nint(awork(21,i_gust)) - if(numgust > 0)then - pw=awork(4,i_gust)/numgust - pw3=awork(22,i_gust)/numgust + numgust=nint(awork(5,i_gust)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional gust data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'gust' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_gust,pflag) + + numgross=nint(awork(6,i_gust)) + numfailqc=nint(awork(21,i_gust)) + if(numgust > 0)then + pw=awork(4,i_gust)/numgust + pw3=awork(22,i_gust)/numgust + end if + write(iout_gust,925) 'gust',numgross,numfailqc end if - write(iout_gust,925) 'gust',numgross,numfailqc - end if - write(iout_gust,950) 'gust',jiter,nread,nkeep,numgust - write(iout_gust,951) 'gust',awork(4,i_gust),awork(22,i_gust),pw,pw3 + write(iout_gust,950) 'gust',jiter,nread,nkeep,numgust + write(iout_gust,951) 'gust',awork(4,i_gust),awork(22,i_gust),pw,pw3 - close(iout_gust) + close(iout_gust) + end if end if ! Summary report for conventional vis if(mype==mype_vis) then - if(first)then - open(iout_vis) - else - open(iout_vis,position='append') - end if - - numvis=nint(awork(5,i_vis)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -557,37 +562,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional vis data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'vis' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vis,pflag) + if(nread > 0)then + if(first)then + open(iout_vis) + else + open(iout_vis,position='append') + end if - numgross=nint(awork(6,i_vis)) - numfailqc=nint(awork(21,i_vis)) - if(numvis > 0)then - pw=awork(4,i_vis)/numvis - pw3=awork(22,i_vis)/numvis + numvis=nint(awork(5,i_vis)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional vis data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'vis' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vis,pflag) + + numgross=nint(awork(6,i_vis)) + numfailqc=nint(awork(21,i_vis)) + if(numvis > 0)then + pw=awork(4,i_vis)/numvis + pw3=awork(22,i_vis)/numvis + end if + write(iout_vis,925) 'vis',numgross,numfailqc end if - write(iout_vis,925) 'vis',numgross,numfailqc - end if - write(iout_vis,950) 'vis',jiter,nread,nkeep,numvis - write(iout_vis,951) 'vis',awork(4,i_vis),awork(22,i_vis),pw,pw3 + write(iout_vis,950) 'vis',jiter,nread,nkeep,numvis + write(iout_vis,951) 'vis',awork(4,i_vis),awork(22,i_vis),pw,pw3 - close(iout_vis) + close(iout_vis) + end if end if ! Summary report for conventional pblh if(mype==mype_pblh) then - if(first)then - open(iout_pblh) - else - open(iout_pblh,position='append') - end if - - numpblh=nint(awork(5,i_pblh)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -596,37 +603,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional pblh data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pblh' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pblh,pflag) + if(nread > 0)then + if(first)then + open(iout_pblh) + else + open(iout_pblh,position='append') + end if - numgross=nint(awork(6,i_pblh)) - numfailqc=nint(awork(21,i_pblh)) - if(numpblh > 0)then - pw=awork(4,i_pblh)/numpblh - pw3=awork(22,i_pblh)/numpblh + numpblh=nint(awork(5,i_pblh)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional pblh data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pblh' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pblh,pflag) + + numgross=nint(awork(6,i_pblh)) + numfailqc=nint(awork(21,i_pblh)) + if(numpblh > 0)then + pw=awork(4,i_pblh)/numpblh + pw3=awork(22,i_pblh)/numpblh + end if + write(iout_pblh,925) 'pblh',numgross,numfailqc end if - write(iout_pblh,925) 'pblh',numgross,numfailqc - end if - write(iout_pblh,950) 'pblh',jiter,nread,nkeep,numpblh - write(iout_pblh,951) 'pblh',awork(4,i_pblh),awork(22,i_pblh),pw,pw3 + write(iout_pblh,950) 'pblh',jiter,nread,nkeep,numpblh + write(iout_pblh,951) 'pblh',awork(4,i_pblh),awork(22,i_pblh),pw,pw3 - close(iout_pblh) + close(iout_pblh) + end if end if ! Summary report for conventional wspd10m if(mype==mype_wspd10m) then - if(first)then - open(iout_wspd10m) - else - open(iout_wspd10m,position='append') - end if - - numwspd10m=nint(awork(5,i_wspd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -635,37 +644,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional wspd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'wspd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_wspd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_wspd10m) + else + open(iout_wspd10m,position='append') + end if - numgross=nint(awork(6,i_wspd10m)) - numfailqc=nint(awork(21,i_wspd10m)) - if(numwspd10m > 0)then - pw=awork(4,i_wspd10m)/numwspd10m - pw3=awork(22,i_wspd10m)/numwspd10m + numwspd10m=nint(awork(5,i_wspd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional wspd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'wspd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_wspd10m,pflag) + + numgross=nint(awork(6,i_wspd10m)) + numfailqc=nint(awork(21,i_wspd10m)) + if(numwspd10m > 0)then + pw=awork(4,i_wspd10m)/numwspd10m + pw3=awork(22,i_wspd10m)/numwspd10m + end if + write(iout_wspd10m,925) 'wspd10m',numgross,numfailqc end if - write(iout_wspd10m,925) 'wspd10m',numgross,numfailqc - end if - write(iout_wspd10m,950) 'wspd10m',jiter,nread,nkeep,numwspd10m - write(iout_wspd10m,951) 'wspd10m',awork(4,i_wspd10m),awork(22,i_wspd10m),pw,pw3 + write(iout_wspd10m,950) 'wspd10m',jiter,nread,nkeep,numwspd10m + write(iout_wspd10m,951) 'wspd10m',awork(4,i_wspd10m),awork(22,i_wspd10m),pw,pw3 - close(iout_wspd10m) + close(iout_wspd10m) + end if end if ! Summary report for conventional td2m if(mype==mype_td2m) then - if(first)then - open(iout_td2m) - else - open(iout_td2m,position='append') - end if - - numtd2m=nint(awork(5,i_td2m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -674,37 +685,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional td2m data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'td2m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_td2m,pflag) + if(nread > 0)then + if(first)then + open(iout_td2m) + else + open(iout_td2m,position='append') + end if - numgross=nint(awork(6,i_td2m)) - numfailqc=nint(awork(21,i_td2m)) - if(numtd2m > 0)then - pw=awork(4,i_td2m)/numtd2m - pw3=awork(22,i_td2m)/numtd2m + numtd2m=nint(awork(5,i_td2m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional td2m data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'td2m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_td2m,pflag) + + numgross=nint(awork(6,i_td2m)) + numfailqc=nint(awork(21,i_td2m)) + if(numtd2m > 0)then + pw=awork(4,i_td2m)/numtd2m + pw3=awork(22,i_td2m)/numtd2m + end if + write(iout_td2m,925) 'td2m',numgross,numfailqc end if - write(iout_td2m,925) 'td2m',numgross,numfailqc - end if - write(iout_td2m,950) 'td2m',jiter,nread,nkeep,numtd2m - write(iout_td2m,951) 'td2m',awork(4,i_td2m),awork(22,i_td2m),pw,pw3 + write(iout_td2m,950) 'td2m',jiter,nread,nkeep,numtd2m + write(iout_td2m,951) 'td2m',awork(4,i_td2m),awork(22,i_td2m),pw,pw3 - close(iout_td2m) + close(iout_td2m) + end if end if ! Summary report for conventional mxtm if(mype==mype_mxtm) then - if(first)then - open(iout_mxtm) - else - open(iout_mxtm,position='append') - end if - - nummxtm=nint(awork(5,i_mxtm)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -713,37 +726,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional mxtm data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'mxtm' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mxtm,pflag) + if(nread > 0)then + if(first)then + open(iout_mxtm) + else + open(iout_mxtm,position='append') + end if - numgross=nint(awork(6,i_mxtm)) - numfailqc=nint(awork(21,i_mxtm)) - if(nummxtm > 0)then - pw=awork(4,i_mxtm)/nummxtm - pw3=awork(22,i_mxtm)/nummxtm + nummxtm=nint(awork(5,i_mxtm)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional mxtm data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'mxtm' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mxtm,pflag) + + numgross=nint(awork(6,i_mxtm)) + numfailqc=nint(awork(21,i_mxtm)) + if(nummxtm > 0)then + pw=awork(4,i_mxtm)/nummxtm + pw3=awork(22,i_mxtm)/nummxtm + end if + write(iout_mxtm,925) 'mxtm',numgross,numfailqc end if - write(iout_mxtm,925) 'mxtm',numgross,numfailqc - end if - write(iout_mxtm,950) 'mxtm',jiter,nread,nkeep,nummxtm - write(iout_mxtm,951) 'mxtm',awork(4,i_mxtm),awork(22,i_mxtm),pw,pw3 + write(iout_mxtm,950) 'mxtm',jiter,nread,nkeep,nummxtm + write(iout_mxtm,951) 'mxtm',awork(4,i_mxtm),awork(22,i_mxtm),pw,pw3 - close(iout_mxtm) + close(iout_mxtm) + end if end if ! Summary report for conventional mitm if(mype==mype_mitm) then - if(first)then - open(iout_mitm) - else - open(iout_mitm,position='append') - end if - - nummitm=nint(awork(5,i_mitm)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -752,37 +767,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional mitm data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'mitm' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mitm,pflag) + if(nread > 0)then + if(first)then + open(iout_mitm) + else + open(iout_mitm,position='append') + end if - numgross=nint(awork(6,i_mitm)) - numfailqc=nint(awork(21,i_mitm)) - if(nummitm > 0)then - pw=awork(4,i_mitm)/nummitm - pw3=awork(22,i_mitm)/nummitm + nummitm=nint(awork(5,i_mitm)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional mitm data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'mitm' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mitm,pflag) + + numgross=nint(awork(6,i_mitm)) + numfailqc=nint(awork(21,i_mitm)) + if(nummitm > 0)then + pw=awork(4,i_mitm)/nummitm + pw3=awork(22,i_mitm)/nummitm + end if + write(iout_mitm,925) 'mitm',numgross,numfailqc end if - write(iout_mitm,925) 'mitm',numgross,numfailqc - end if - write(iout_mitm,950) 'mitm',jiter,nread,nkeep,nummitm - write(iout_mitm,951) 'mitm',awork(4,i_mitm),awork(22,i_mitm),pw,pw3 + write(iout_mitm,950) 'mitm',jiter,nread,nkeep,nummitm + write(iout_mitm,951) 'mitm',awork(4,i_mitm),awork(22,i_mitm),pw,pw3 - close(iout_mitm) + close(iout_mitm) + end if end if ! Summary report for conventional pmsl if(mype==mype_pmsl) then - if(first)then - open(iout_pmsl) - else - open(iout_pmsl,position='append') - end if - - numpmsl=nint(awork(5,i_pmsl)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -791,37 +808,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional pmsl data, ranges in hPa $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pmsl' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pmsl,pflag) + if(nread > 0)then + if(first)then + open(iout_pmsl) + else + open(iout_pmsl,position='append') + end if - numgross=nint(awork(6,i_pmsl)) - numfailqc=nint(awork(21,i_pmsl)) - if(numpmsl > 0)then - pw=awork(4,i_pmsl)/numpmsl - pw3=awork(22,i_pmsl)/numpmsl + numpmsl=nint(awork(5,i_pmsl)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional pmsl data, ranges in hPa $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pmsl' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pmsl,pflag) + + numgross=nint(awork(6,i_pmsl)) + numfailqc=nint(awork(21,i_pmsl)) + if(numpmsl > 0)then + pw=awork(4,i_pmsl)/numpmsl + pw3=awork(22,i_pmsl)/numpmsl + end if + write(iout_pmsl,925) 'pmsl',numgross,numfailqc end if - write(iout_pmsl,925) 'pmsl',numgross,numfailqc - end if - write(iout_pmsl,950) 'pmsl',jiter,nread,nkeep,numpmsl - write(iout_pmsl,951) 'pmsl',awork(4,i_pmsl),awork(22,i_pmsl),pw,pw3 + write(iout_pmsl,950) 'pmsl',jiter,nread,nkeep,numpmsl + write(iout_pmsl,951) 'pmsl',awork(4,i_pmsl),awork(22,i_pmsl),pw,pw3 - close(iout_pmsl) + close(iout_pmsl) + end if end if ! Summary report for conventional howv if(mype==mype_howv) then - if(first)then - open(iout_howv) - else - open(iout_howv,position='append') - end if - - numhowv=nint(awork(5,i_howv)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -830,37 +849,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional howv data, ranges in m $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'howv' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_howv,pflag) + if(nread > 0)then + if(first)then + open(iout_howv) + else + open(iout_howv,position='append') + end if - numgross=nint(awork(6,i_howv)) - numfailqc=nint(awork(21,i_howv)) - if(numhowv > 0)then - pw=awork(4,i_howv)/numhowv - pw3=awork(22,i_howv)/numhowv + numhowv=nint(awork(5,i_howv)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional howv data, ranges in m $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'howv' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_howv,pflag) + + numgross=nint(awork(6,i_howv)) + numfailqc=nint(awork(21,i_howv)) + if(numhowv > 0)then + pw=awork(4,i_howv)/numhowv + pw3=awork(22,i_howv)/numhowv + end if + write(iout_howv,925) 'howv',numgross,numfailqc end if - write(iout_howv,925) 'howv',numgross,numfailqc - end if - write(iout_howv,950) 'howv',jiter,nread,nkeep,numhowv - write(iout_howv,951) 'howv',awork(4,i_howv),awork(22,i_howv),pw,pw3 + write(iout_howv,950) 'howv',jiter,nread,nkeep,numhowv + write(iout_howv,951) 'howv',awork(4,i_howv),awork(22,i_howv),pw,pw3 - close(iout_howv) + close(iout_howv) + end if end if ! Summary report for tcamt if(mype==mype_tcamt) then - if(first)then - open(iout_tcamt) - else - open(iout_tcamt,position='append') - end if - - numtcamt=nint(awork(5,i_tcamt)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -869,37 +890,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional tcamt data, ranges in %$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'tcamt' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcamt,pflag) + if(nread > 0)then + if(first)then + open(iout_tcamt) + else + open(iout_tcamt,position='append') + end if - numgross=nint(awork(6,i_tcamt)) - numfailqc=nint(awork(21,i_tcamt)) - if(numtcamt > 0)then - pw=awork(4,i_tcamt)/numtcamt - pw3=awork(22,i_tcamt)/numtcamt + numtcamt=nint(awork(5,i_tcamt)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional tcamt data, ranges in %$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'tcamt' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcamt,pflag) + + numgross=nint(awork(6,i_tcamt)) + numfailqc=nint(awork(21,i_tcamt)) + if(numtcamt > 0)then + pw=awork(4,i_tcamt)/numtcamt + pw3=awork(22,i_tcamt)/numtcamt + end if + write(iout_tcamt,925) 'tcamt',numgross,numfailqc end if - write(iout_tcamt,925) 'tcamt',numgross,numfailqc - end if - write(iout_tcamt,950) 'tcamt',jiter,nread,nkeep,numtcamt - write(iout_tcamt,951) 'tcamt',awork(4,i_tcamt),awork(22,i_tcamt),pw,pw3 + write(iout_tcamt,950) 'tcamt',jiter,nread,nkeep,numtcamt + write(iout_tcamt,951) 'tcamt',awork(4,i_tcamt),awork(22,i_tcamt),pw,pw3 - close(iout_tcamt) + close(iout_tcamt) + end if end if ! Summary report for lcbas if(mype==mype_lcbas) then - if(first)then - open(iout_lcbas) - else - open(iout_lcbas,position='append') - end if - - numlcbas=nint(awork(5,i_lcbas)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -908,37 +931,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional lcbas data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lcbas' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lcbas,pflag) + if(nread > 0)then + if(first)then + open(iout_lcbas) + else + open(iout_lcbas,position='append') + end if - numgross=nint(awork(6,i_lcbas)) - numfailqc=nint(awork(21,i_lcbas)) - if(numlcbas > 0)then - pw=awork(4,i_lcbas)/numlcbas - pw3=awork(22,i_lcbas)/numlcbas + numlcbas=nint(awork(5,i_lcbas)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional lcbas data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lcbas' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lcbas,pflag) + + numgross=nint(awork(6,i_lcbas)) + numfailqc=nint(awork(21,i_lcbas)) + if(numlcbas > 0)then + pw=awork(4,i_lcbas)/numlcbas + pw3=awork(22,i_lcbas)/numlcbas + end if + write(iout_lcbas,925) 'lcbas',numgross,numfailqc end if - write(iout_lcbas,925) 'lcbas',numgross,numfailqc - end if - write(iout_lcbas,950) 'lcbas',jiter,nread,nkeep,numlcbas - write(iout_lcbas,951) 'lcbas',awork(4,i_lcbas),awork(22,i_lcbas),pw,pw3 + write(iout_lcbas,950) 'lcbas',jiter,nread,nkeep,numlcbas + write(iout_lcbas,951) 'lcbas',awork(4,i_lcbas),awork(22,i_lcbas),pw,pw3 - close(iout_lcbas) + close(iout_lcbas) + end if end if ! Summary report for conventional cldch if(mype==mype_cldch) then - if(first)then - open(iout_cldch) - else - open(iout_cldch,position='append') - end if - - numcldch=nint(awork(5,i_cldch)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -947,37 +972,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional cldch data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'cldch' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_cldch,pflag) + if(nread > 0)then + if(first)then + open(iout_cldch) + else + open(iout_cldch,position='append') + end if - numgross=nint(awork(6,i_cldch)) - numfailqc=nint(awork(21,i_cldch)) - if(numcldch > 0)then - pw=awork(4,i_cldch)/numcldch - pw3=awork(22,i_cldch)/numcldch + numcldch=nint(awork(5,i_cldch)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional cldch data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'cldch' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_cldch,pflag) + + numgross=nint(awork(6,i_cldch)) + numfailqc=nint(awork(21,i_cldch)) + if(numcldch > 0)then + pw=awork(4,i_cldch)/numcldch + pw3=awork(22,i_cldch)/numcldch + end if + write(iout_cldch,925) 'cldch',numgross,numfailqc end if - write(iout_cldch,925) 'cldch',numgross,numfailqc - end if - write(iout_cldch,950) 'cldch',jiter,nread,nkeep,numcldch - write(iout_cldch,951) 'cldch',awork(4,i_cldch),awork(22,i_cldch),pw,pw3 + write(iout_cldch,950) 'cldch',jiter,nread,nkeep,numcldch + write(iout_cldch,951) 'cldch',awork(4,i_cldch),awork(22,i_cldch),pw,pw3 - close(iout_cldch) + close(iout_cldch) + end if end if ! Summary report for conventional uwnd10m if(mype==mype_uwnd10m) then - if(first)then - open(iout_uwnd10m) - else - open(iout_uwnd10m,position='append') - end if - - numuwnd10m=nint(awork(5,i_uwnd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -986,37 +1013,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional uwnd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'uwnd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_uwnd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_uwnd10m) + else + open(iout_uwnd10m,position='append') + end if - numgross=nint(awork(6,i_uwnd10m)) - numfailqc=nint(awork(21,i_uwnd10m)) - if(numuwnd10m > 0)then - pw=awork(4,i_uwnd10m)/numuwnd10m - pw3=awork(22,i_uwnd10m)/numuwnd10m + numuwnd10m=nint(awork(5,i_uwnd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional uwnd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'uwnd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_uwnd10m,pflag) + + numgross=nint(awork(6,i_uwnd10m)) + numfailqc=nint(awork(21,i_uwnd10m)) + if(numuwnd10m > 0)then + pw=awork(4,i_uwnd10m)/numuwnd10m + pw3=awork(22,i_uwnd10m)/numuwnd10m + end if + write(iout_uwnd10m,925) 'uwnd10m',numgross,numfailqc end if - write(iout_uwnd10m,925) 'uwnd10m',numgross,numfailqc - end if - write(iout_uwnd10m,950) 'uwnd10m',jiter,nread,nkeep,numuwnd10m - write(iout_uwnd10m,951) 'uwnd10m',awork(4,i_uwnd10m),awork(22,i_uwnd10m),pw,pw3 + write(iout_uwnd10m,950) 'uwnd10m',jiter,nread,nkeep,numuwnd10m + write(iout_uwnd10m,951) 'uwnd10m',awork(4,i_uwnd10m),awork(22,i_uwnd10m),pw,pw3 - close(iout_uwnd10m) + close(iout_uwnd10m) + end if end if ! Summary report for conventional vwnd10m if(mype==mype_vwnd10m) then - if(first)then - open(iout_vwnd10m) - else - open(iout_vwnd10m,position='append') - end if - - numvwnd10m=nint(awork(5,i_vwnd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -1025,37 +1054,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional vwnd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'vwnd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vwnd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_vwnd10m) + else + open(iout_vwnd10m,position='append') + end if - numgross=nint(awork(6,i_vwnd10m)) - numfailqc=nint(awork(21,i_vwnd10m)) - if(numvwnd10m > 0)then - pw=awork(4,i_vwnd10m)/numvwnd10m - pw3=awork(22,i_vwnd10m)/numvwnd10m + numvwnd10m=nint(awork(5,i_vwnd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional vwnd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'vwnd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vwnd10m,pflag) + + numgross=nint(awork(6,i_vwnd10m)) + numfailqc=nint(awork(21,i_vwnd10m)) + if(numvwnd10m > 0)then + pw=awork(4,i_vwnd10m)/numvwnd10m + pw3=awork(22,i_vwnd10m)/numvwnd10m + end if + write(iout_vwnd10m,925) 'vwnd10m',numgross,numfailqc end if - write(iout_vwnd10m,925) 'vwnd10m',numgross,numfailqc - end if - write(iout_vwnd10m,950) 'vwnd10m',jiter,nread,nkeep,numvwnd10m - write(iout_vwnd10m,951) 'vwnd10m',awork(4,i_vwnd10m),awork(22,i_vwnd10m),pw,pw3 + write(iout_vwnd10m,950) 'vwnd10m',jiter,nread,nkeep,numvwnd10m + write(iout_vwnd10m,951) 'vwnd10m',awork(4,i_vwnd10m),awork(22,i_vwnd10m),pw,pw3 - close(iout_vwnd10m) + close(iout_vwnd10m) + end if end if ! Summary report for temperature if (mype==mype_t)then - if(first)then - open(iout_t) - else - open(iout_t,position='append') - end if - - tmplty=zero; tqcplty=zero ; ntot=0 - tt=zero ; qctt=zero nread=0 nkeep=0 do i=1,ndat @@ -1064,54 +1095,56 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of temperature data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 't' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_t,pflag) - do k=1,nsig - num(k)=nint(awork(5*nsig+k+100,i_t)) - rat=zero ; rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_t)/float(num(k)) - rat3=awork(3*nsig+k+100,i_t)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_t) + else + open(iout_t,position='append') + end if + + tmplty=zero; tqcplty=zero ; ntot=0 + tt=zero ; qctt=zero + if(nkeep > 0)then + mesage='current fit of temperature data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 't' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_t,pflag) + do k=1,nsig + num(k)=nint(awork(5*nsig+k+100,i_t)) + rat=zero ; rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_t)/float(num(k)) + rat3=awork(3*nsig+k+100,i_t)/float(num(k)) + end if + ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t) + tqcplty=tqcplty+awork(3*nsig+k+100,i_t) + write(iout_t,240) 't',num(k),k,awork(6*nsig+k+100,i_t), & + awork(3*nsig+k+100,i_t),rat,rat3 + end do + numgross=nint(awork(4,i_t)) + numfailqc=nint(awork(21,i_t)) + write(iout_t,925) 'temp',numgross,numfailqc + numlow = nint(awork(2,i_t)) + numhgh = nint(awork(3,i_t)) + write(iout_t,900) 't',numhgh,numlow + if(ntot > 0) then + tt=tmplty/ntot + qctt=tqcplty/ntot end if - ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t) - tqcplty=tqcplty+awork(3*nsig+k+100,i_t) - write(iout_t,240) 't',num(k),k,awork(6*nsig+k+100,i_t), & - awork(3*nsig+k+100,i_t),rat,rat3 - end do - numgross=nint(awork(4,i_t)) - numfailqc=nint(awork(21,i_t)) - write(iout_t,925) 'temp',numgross,numfailqc - numlow = nint(awork(2,i_t)) - numhgh = nint(awork(3,i_t)) - write(iout_t,900) 't',numhgh,numlow - if(ntot > 0) then - tt=tmplty/ntot - qctt=tqcplty/ntot end if - end if - write(iout_t,950) 't',jiter,nread,nkeep,ntot - write(iout_t,951) 't',tmplty,tqcplty,tt,qctt + write(iout_t,950) 't',jiter,nread,nkeep,ntot + write(iout_t,951) 't',tmplty,tqcplty,tt,qctt - close(iout_t) + close(iout_t) + end if endif ! Summary report for doppler lidar winds if(mype==mype_dw) then - if(first)then - open(iout_dw) - else - open(iout_dw,position='append') - end if - - dwmplty=zero; dwqcplty=zero ; ntot=0 - tdw=zero ; qctdw=zero nread=0 nkeep=0 do i=1,ndat @@ -1120,56 +1153,58 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of lidar wind data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'dw' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dw,pflag) + if(nread > 0)then + if(first)then + open(iout_dw) + else + open(iout_dw,position='append') + end if + + dwmplty=zero; dwqcplty=zero ; ntot=0 + tdw=zero ; qctdw=zero + if(nkeep > 0)then + mesage='current vfit of lidar wind data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'dw' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dw,pflag) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_dw)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_dw)/float(num(k)) - rat3=awork(3*nsig+k+100,i_dw)/float(num(k)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_dw)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_dw)/float(num(k)) + rat3=awork(3*nsig+k+100,i_dw)/float(num(k)) + end if + ntot=ntot+num(k) + dwmplty=dwmplty+awork(6*nsig+k+100,i_dw) + dwqcplty=dwqcplty+awork(3*nsig+k+100,i_dw) + write(iout_dw,240) 'r',num(k),k,awork(6*nsig+k+100,i_dw), & + awork(3*nsig+k+100,i_dw),rat,rat3 + end do + numgross=nint(awork(4,i_dw)) + numfailqc=nint(awork(21,i_dw)) + if(ntot > 0) then + tdw=dwmplty/float(ntot) + qctdw=dwqcplty/float(ntot) end if - ntot=ntot+num(k) - dwmplty=dwmplty+awork(6*nsig+k+100,i_dw) - dwqcplty=dwqcplty+awork(3*nsig+k+100,i_dw) - write(iout_dw,240) 'r',num(k),k,awork(6*nsig+k+100,i_dw), & - awork(3*nsig+k+100,i_dw),rat,rat3 - end do - numgross=nint(awork(4,i_dw)) - numfailqc=nint(awork(21,i_dw)) - if(ntot > 0) then - tdw=dwmplty/float(ntot) - qctdw=dwqcplty/float(ntot) - end if - write(iout_dw,925) 'dw',numgross,numfailqc - numlow = nint(awork(2,i_dw)) - numhgh = nint(awork(3,i_dw)) - write(iout_dw,900) 'dw',numhgh,numlow - end if + write(iout_dw,925) 'dw',numgross,numfailqc + numlow = nint(awork(2,i_dw)) + numhgh = nint(awork(3,i_dw)) + write(iout_dw,900) 'dw',numhgh,numlow + end if - write(iout_dw,950) 'dw',jiter,nread,nkeep,ntot - write(iout_dw,951) 'dw',dwmplty,dwqcplty,tdw,qctdw + write(iout_dw,950) 'dw',jiter,nread,nkeep,ntot + write(iout_dw,951) 'dw',dwmplty,dwqcplty,tdw,qctdw - close(iout_dw) + close(iout_dw) + end if end if ! Summary report for radar radial winds if(mype==mype_rw) then - if(first)then - open(iout_rw) - else - open(iout_rw,position='append') - end if - - rwmplty=zero; rwqcplty=zero ; ntot=0 - trw=zero ; qctrw=zero nread=0 nkeep=0 do i=1,ndat @@ -1178,57 +1213,59 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of radar wind data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'rw' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_rw,pflag) + if(nread > 0)then + if(first)then + open(iout_rw) + else + open(iout_rw,position='append') + end if + + rwmplty=zero; rwqcplty=zero ; ntot=0 + trw=zero ; qctrw=zero + if(nkeep > 0)then + mesage='current vfit of radar wind data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'rw' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_rw,pflag) - numgross=nint(awork(4,i_rw)) - numfailqc=nint(awork(21,i_rw)) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_rw)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_rw)/float(num(k)) - rat3=awork(3*nsig+k+100,i_rw)/float(num(k)) + numgross=nint(awork(4,i_rw)) + numfailqc=nint(awork(21,i_rw)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_rw)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_rw)/float(num(k)) + rat3=awork(3*nsig+k+100,i_rw)/float(num(k)) + end if + ntot=ntot+num(k) + rwmplty=rwmplty+awork(6*nsig+k+100,i_rw) + rwqcplty=rwqcplty+awork(3*nsig+k+100,i_rw) + write(iout_rw,240) 'r',num(k),k,awork(6*nsig+k+100,i_rw), & + awork(3*nsig+k+100,i_rw),rat,rat3 + end do + if(ntot > 0) then + trw=rwmplty/float(ntot) + qctrw=rwqcplty/float(ntot) end if - ntot=ntot+num(k) - rwmplty=rwmplty+awork(6*nsig+k+100,i_rw) - rwqcplty=rwqcplty+awork(3*nsig+k+100,i_rw) - write(iout_rw,240) 'r',num(k),k,awork(6*nsig+k+100,i_rw), & - awork(3*nsig+k+100,i_rw),rat,rat3 - end do - if(ntot > 0) then - trw=rwmplty/float(ntot) - qctrw=rwqcplty/float(ntot) - end if - write(iout_rw,925) 'rw',numgross,numfailqc - numlow = nint(awork(2,i_rw)) - numhgh = nint(awork(3,i_rw)) - nhitopo = nint(awork(5,i_rw)) - ntoodif = nint(awork(6,i_rw)) - write(iout_rw,900) 'rw',numhgh,numlow - write(iout_rw,905) 'rw',nhitopo,ntoodif - end if - write(iout_rw,950) 'rw',jiter,nread,nkeep,ntot - write(iout_rw,951) 'rw',rwmplty,rwqcplty,trw,qctrw + write(iout_rw,925) 'rw',numgross,numfailqc + numlow = nint(awork(2,i_rw)) + numhgh = nint(awork(3,i_rw)) + nhitopo = nint(awork(5,i_rw)) + ntoodif = nint(awork(6,i_rw)) + write(iout_rw,900) 'rw',numhgh,numlow + write(iout_rw,905) 'rw',nhitopo,ntoodif + end if + write(iout_rw,950) 'rw',jiter,nread,nkeep,ntot + write(iout_rw,951) 'rw',rwmplty,rwqcplty,trw,qctrw - close(iout_rw) + close(iout_rw) + end if end if ! Summary report for radar reflectivity if(mype==mype_dbz) then - if(first)then - open(iout_dbz) - else - open(iout_dbz,position='append') - end if - - dbzmplty=zero; dbzqcplty=zero ; ntot=0 - tdbz=zero ; qctdbz=zero nread=0 nkeep=0 do i=1,ndat @@ -1237,56 +1274,58 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of radar reflectivity data, ranges in dBZ$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'dbz' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag) - - numgross=nint(awork(4,i_dbz)) - numfailqc=nint(awork(21,i_dbz)) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_dbz)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_dbz)/float(num(k)) - rat3=awork(3*nsig+k+100,i_dbz)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_dbz) + else + open(iout_dbz,position='append') + end if + + dbzmplty=zero; dbzqcplty=zero ; ntot=0 + tdbz=zero ; qctdbz=zero + if(nkeep > 0)then + mesage='current vfit of radar reflectivity data, ranges in dBZ$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'dbz' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag) + + numgross=nint(awork(4,i_dbz)) + numfailqc=nint(awork(21,i_dbz)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_dbz)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_dbz)/float(num(k)) + rat3=awork(3*nsig+k+100,i_dbz)/float(num(k)) + end if + ntot=ntot+num(k) + dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz) + dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz) + write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), & + awork(3*nsig+k+100,i_dbz),rat,rat3 + end do + if(ntot > 0) then + tdbz=dbzmplty/float(ntot) + qctdbz=dbzqcplty/float(ntot) end if - ntot=ntot+num(k) - dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz) - dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz) - write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), & - awork(3*nsig+k+100,i_dbz),rat,rat3 - end do - if(ntot > 0) then - tdbz=dbzmplty/float(ntot) - qctdbz=dbzqcplty/float(ntot) - end if - write(iout_dbz,925) 'dbz',numgross,numfailqc - numlow = nint(awork(2,i_dbz)) - numhgh = nint(awork(3,i_dbz)) - nhitopo = nint(awork(5,i_dbz)) - ntoodif = nint(awork(6,i_dbz)) - write(iout_dbz,900) 'dbz',numhgh,numlow - write(iout_dbz,905) 'dbz',nhitopo,ntoodif - end if - write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot - write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz + write(iout_dbz,925) 'dbz',numgross,numfailqc + numlow = nint(awork(2,i_dbz)) + numhgh = nint(awork(3,i_dbz)) + nhitopo = nint(awork(5,i_dbz)) + ntoodif = nint(awork(6,i_dbz)) + write(iout_dbz,900) 'dbz',numhgh,numlow + write(iout_dbz,905) 'dbz',nhitopo,ntoodif + end if + write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot + write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz - close(iout_dbz) + close(iout_dbz) + end if end if if(mype==mype_tcp) then - if(first)then - open(iout_tcp) - else - open(iout_tcp,position='append') - end if - - nump=nint(awork(5,i_tcp)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -1295,39 +1334,41 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of surface pressure data, ranges in mb$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'tcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcp,pflag) - - numgross=nint(awork(6,i_tcp)) - numfailqc=nint(awork(21,i_tcp)) - write(iout_tcp,925) 'psfc',numgross,numfailqc + if(nread > 0)then + if(first)then + open(iout_tcp) + else + open(iout_tcp,position='append') + end if - if(nump > 0)then - pw=awork(4,i_tcp)/float(nump) - pw3=awork(22,i_tcp)/float(nump) + nump=nint(awork(5,i_tcp)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of surface pressure data, ranges in mb$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'tcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcp,pflag) + + numgross=nint(awork(6,i_tcp)) + numfailqc=nint(awork(21,i_tcp)) + write(iout_tcp,925) 'psfc',numgross,numfailqc + + if(nump > 0)then + pw=awork(4,i_tcp)/float(nump) + pw3=awork(22,i_tcp)/float(nump) + end if end if - end if - write(iout_tcp,950) 'psfc',jiter,nread,nkeep,nump - write(iout_tcp,951) 'psfc',awork(4,i_tcp),awork(22,i_tcp),pw,pw3 + write(iout_tcp,950) 'psfc',jiter,nread,nkeep,nump + write(iout_tcp,951) 'psfc',awork(4,i_tcp),awork(22,i_tcp),pw,pw3 - close(iout_tcp) + close(iout_tcp) + end if end if ! Summary report for lagrangian if (mype==mype_lag)then - if(first)then - open(iout_lag) - else - open(iout_lag,position='append') - end if - - tmplty=zero; tqcplty=zero ; ntot=0 - tt=zero ; qctt=zero nread=0 nkeep=0 do i=1,ndat @@ -1336,53 +1377,54 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of lagangian data, ranges in m $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lag' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_lag,pflag) - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_lag)) - rat=zero ; rat3=zero - if(num(k) > 0) then - rat=awork(4*nsig+k+100,i_lag)/float(num(k)) - rat3=awork(3*nsig+k+100,i_lag)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_lag) + else + open(iout_lag,position='append') + end if + + tmplty=zero; tqcplty=zero ; ntot=0 + tt=zero ; qctt=zero + if(nkeep > 0)then + mesage='current fit of lagangian data, ranges in m $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lag' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_lag,pflag) + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_lag)) + rat=zero ; rat3=zero + if(num(k) > 0) then + rat=awork(4*nsig+k+100,i_lag)/float(num(k)) + rat3=awork(3*nsig+k+100,i_lag)/float(num(k)) + end if + ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag) + tqcplty=tqcplty+awork(3*nsig+k+100,i_lag) + write(iout_lag,240) 'lag',num(k),k,awork(4*nsig+k+100,i_lag), & + awork(3*nsig+k+100,i_lag),rat,rat3 + end do + numgross=nint(awork(4,i_lag)) + numfailqc=nint(awork(21,i_lag)) + write(iout_lag,925) 'lag',numgross,numfailqc + ! numlow = nint(awork(2,i_t)) + ! numhgh = nint(awork(3,i_t)) + ! write(iout_lag,900) 't',numhgh,numlow + if(ntot > 0) then + tt=tmplty/ntot + qctt=tqcplty/ntot end if - ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag) - tqcplty=tqcplty+awork(3*nsig+k+100,i_lag) - write(iout_lag,240) 'lag',num(k),k,awork(4*nsig+k+100,i_lag), & - awork(3*nsig+k+100,i_lag),rat,rat3 - end do - numgross=nint(awork(4,i_lag)) - numfailqc=nint(awork(21,i_lag)) - write(iout_lag,925) 'lag',numgross,numfailqc - ! numlow = nint(awork(2,i_t)) - ! numhgh = nint(awork(3,i_t)) - ! write(iout_lag,900) 't',numhgh,numlow - if(ntot > 0) then - tt=tmplty/ntot - qctt=tqcplty/ntot end if - end if - write(iout_lag,950) 'lag',jiter,nread,nkeep,ntot - write(iout_lag,951) 'lag',tmplty,tqcplty,tt,qctt + write(iout_lag,950) 'lag',jiter,nread,nkeep,ntot + write(iout_lag,951) 'lag',tmplty,tqcplty,tt,qctt - close(iout_lag) + close(iout_lag) + end if endif ! Summary report for solid-water content path if(mype==mype_swcp) then - if(first)then - open(iout_swcp) - else - open(iout_swcp,position='append') - end if - - nsuperp=nint(awork(4,i_swcp)) - - tswcp=zero ; tswcp3=zero nread=0 nkeep=0 do i=1,ndat @@ -1391,42 +1433,44 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of solid-water content path, ranges in kg/m^2$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'swcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag) - - numgrsswcp=nint(awork(6,i_swcp)) - numfailqc=nint(awork(21,i_swcp)) - grsmlt=three - tswcp=zero - tswcp3=zero - if(nsuperp > 0)then - tswcp=awork(5,i_swcp)/nsuperp - tswcp3=awork(22,i_swcp)/nsuperp - end if - write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc - write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp) - end if - write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp - write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3 + if(nread > 0)then + if(first)then + open(iout_swcp) + else + open(iout_swcp,position='append') + end if + + nsuperp=nint(awork(4,i_swcp)) + + tswcp=zero ; tswcp3=zero + if(nkeep > 0)then + mesage='current fit of solid-water content path, ranges in kg/m^2$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'swcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag) + + numgrsswcp=nint(awork(6,i_swcp)) + numfailqc=nint(awork(21,i_swcp)) + grsmlt=three + tswcp=zero + tswcp3=zero + if(nsuperp > 0)then + tswcp=awork(5,i_swcp)/nsuperp + tswcp3=awork(22,i_swcp)/nsuperp + end if + write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc + write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp) + end if + write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp + write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3 - close(iout_swcp) + close(iout_swcp) + end if end if ! Summary report for liquid-water content path if(mype==mype_lwcp) then - if(first)then - open(iout_lwcp) - else - open(iout_lwcp,position='append') - end if - - nsuperp=nint(awork(4,i_lwcp)) - - tlwcp=zero ; tlwcp3=zero nread=0 nkeep=0 do i=1,ndat @@ -1435,29 +1479,40 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of liquid-water content path, ranges in kg/m^2$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lwcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag) - - numgrslwcp=nint(awork(6,i_lwcp)) - numfailqc=nint(awork(21,i_lwcp)) - grsmlt=three - tlwcp=zero - tlwcp3=zero - if(nsuperp > 0)then - tlwcp=awork(5,i_lwcp)/nsuperp - tlwcp3=awork(22,i_lwcp)/nsuperp - end if - write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc - write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp) - end if - write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp - write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3 + if(nread > 0)then + if(first)then + open(iout_lwcp) + else + open(iout_lwcp,position='append') + end if - close(iout_lwcp) + nsuperp=nint(awork(4,i_lwcp)) + + tlwcp=zero ; tlwcp3=zero + if(nkeep > 0)then + mesage='current fit of liquid-water content path, ranges in kg/m^2$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lwcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag) + + numgrslwcp=nint(awork(6,i_lwcp)) + numfailqc=nint(awork(21,i_lwcp)) + grsmlt=three + tlwcp=zero + tlwcp3=zero + if(nsuperp > 0)then + tlwcp=awork(5,i_lwcp)/nsuperp + tlwcp3=awork(22,i_lwcp)/nsuperp + end if + write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc + write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp) + end if + write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp + write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3 + + close(iout_lwcp) + end if end if diff --git a/src/gsi/statslight.f90 b/src/gsi/statslight.f90 index ffcdef6a0a..7f8e7c8349 100644 --- a/src/gsi/statslight.f90 +++ b/src/gsi/statslight.f90 @@ -56,31 +56,14 @@ subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata) real(r_kind) grsmlt,tlight real(r_kind) tlight3 - real(r_kind),dimension(1):: pbotall,ptopall logical,dimension(nlighttype):: pflag !********************************************************************************* -! Initialize constants and variables. - ptopall(1)=zero; pbotall(1)=2000.0_r_kind - - -! Generate summary statistics - - pflag=.FALSE. - -! Summary report for lightning flash rate +! Generate statistics Summary report for lightning flash rate if(mype==mype_light) then - if(first)then - open(iout_light) - else - open(iout_light,position='append') - end if - - nsuperl=nint(awork(4,i_light)) - tlight=zero ; tlight3=zero nread=0 nkeep=0 do i=1,ndat @@ -89,29 +72,40 @@ subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata) nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of lightning data, range in #hits km-2 hr-1$' - do j=1,nlighttype - pflag(j)=trim(nulight(j)) == 'light' - enddo - - call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag) + if(nread > 0)then + pflag=.FALSE. + if(first)then + open(iout_light) + else + open(iout_light,position='append') + end if - numgrslight=nint(awork(6,i_light)) - numfailqc=nint(awork(21,i_light)) - grsmlt=three - tlight=zero - if(nsuperl > 0)then - tlight=awork(5,i_light)/nsuperl - tlight3=awork(22,i_light)/nsuperl + nsuperl=nint(awork(4,i_light)) + tlight=zero ; tlight3=zero + if(nkeep > 0)then + mesage='current fit of lightning data, range in #hits km-2 hr-1$' + do j=1,nlighttype + pflag(j)=trim(nulight(j)) == 'light' + enddo + + call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag) + + numgrslight=nint(awork(6,i_light)) + numfailqc=nint(awork(21,i_light)) + grsmlt=three + tlight=zero + if(nsuperl > 0)then + tlight=awork(5,i_light)/nsuperl + tlight3=awork(22,i_light)/nsuperl + end if + write(iout_light,925) 'light',numgrslight,numfailqc + write(iout_light,975) grsmlt,'light',awork(7,i_light) end if - write(iout_light,925) 'light',numgrslight,numfailqc - write(iout_light,975) grsmlt,'light',awork(7,i_light) - end if - write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl - write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3 + write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl + write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3 - close(iout_light) + close(iout_light) + end if end if diff --git a/src/gsi/statsrad.f90 b/src/gsi/statsrad.f90 index c6a993092c..121761fa76 100644 --- a/src/gsi/statsrad.f90 +++ b/src/gsi/statsrad.f90 @@ -142,7 +142,7 @@ subroutine statsrad(aivals,stats,ndata) ! Write obs count to runtime output file write(iout_rad,1109) do i=1,ndat - if(idisplay(i))then + if(idisplay(i) .and. ndata(i,2) > 0)then iobs2 = nint(aivals(38,i)) qcpenal = aivals(39,i) rpenal = aivals(40,i) @@ -162,9 +162,9 @@ subroutine statsrad(aivals,stats,ndata) 2012 format(12x,A7,5x,8(a7,1x)) 2999 format(' Illegal satellite type ') 1102 format(1x,i4,i5,1x,a16,2i7,1x,f10.3,1x,6(f11.7,1x)) -1109 format(t5,'it',t13,'satellite',t23,'instrument',t38, & - '# read',t49,'# keep',t59,'# assim',& - t68,'penalty',t81,'qcpnlty',t95,'cpen',t105,'qccpen') +1109 format(t5,'it',t13,'satellite',t23,'instrument',t40, & + '# read',t53,'# keep',t65,'# assim',& + t75,'penalty',t88,'qcpnlty',t104,'cpen',t115,'qccpen') 1115 format('o-g',1x,i2.2,1x,'rad',2x,2A10,2x,3(i11,2x),4(g12.5,1x)) ! Close output unit diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index 80fac64d61..30387341e3 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -226,17 +226,19 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & use stpjcmod, only: stplimq,stplimg,stplimv,stplimp,stplimw10m,& stplimhowv,stplimcldch,stpjcdfi,stpjcpdry,stpliml,stplimqc use bias_predictors, only: predictors - use control_vectors, only: control_vector,qdot_prod_sub,cvars2d,cvars3d + use control_vectors, only: control_vector,qdot_prod_sub + use state_vectors, only: qgpresent,qspresent,qrpresent,qipresent,qlpresent + use state_vectors, only: cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent use state_vectors, only: allocate_state,deallocate_state use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: assignment(=) use guess_grids, only: ntguessig,nfldsig use mpl_allreducemod, only: mpl_allreduce - use mpeu_util, only: getindex use timermod, only: timer_ini,timer_fnl use stpjomod, only: stpjo use gsi_io, only: verbose + use gridmod, only: minmype implicit none ! Declare passed variables @@ -266,20 +268,19 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & real(r_quad),dimension(4,ipen):: pbc real(r_quad),dimension(4,nobs_type):: pbcjo real(r_quad),dimension(4,nobs_type,nobs_bins):: pbcjoi - real(r_quad),dimension(4,nobs_bins):: pbcqmin,pbcqmax + real(r_quad),dimension(4):: pbcqmin,pbcqmax real(r_quad),dimension(4,nobs_bins):: pbcql,pbcqi,pbcqr,pbcqs,pbcqg real(r_quad),dimension(ipen):: pen_est real(r_quad),dimension(3,ipenlin):: pstart real(r_quad) bx,cx,ccoef,bcoef,dels,sges1,sgesj real(r_quad),dimension(0:istp_iter):: stp real(r_kind),dimension(istp_iter):: stprat - real(r_quad),dimension(ipen):: bsum,csum,bsum_save,csum_save,pen_save + real(r_quad),dimension(ipen):: bsum,csum real(r_quad),dimension(ipen,nobs_bins):: pj real(r_kind) delpen real(r_kind) outpensave real(r_kind),dimension(4)::sges real(r_kind),dimension(ioutpen):: outpen,outstp - logical :: cxterm,change_dels,ifound logical :: print_verbose,pjcalc @@ -290,7 +291,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! Initialize variable print_verbose=.false. if(verbose)print_verbose=.true. - cxterm=.false. mm1=mype+1 stp(0)=stpinout outpen = zero @@ -387,10 +387,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! there, if one has to know or to reference them explicitly. pstart=zero_quad - pbc=zero_quad if(iter == 0 .and. kprt >= 2)pjcalc=.true. + ! penalty, b and c for background terms pstart(1,1) = qdot_prod_sub(xhatsave,yhatsave) @@ -426,11 +426,11 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & dels = one_tenth_quad stepsize: do ii=1,istp_iter + pbc=zero_quad pjcalc=.false. if(iter == 0 .and. kprt >= 2 .and. ii == 1)pjcalc=.true. iis=ii ! Delta stepsize - change_dels=.true. sges(1)= stp(ii-1) sges(2)=(one_quad-dels)*stp(ii-1) @@ -448,7 +448,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if ! Calculate penalty values for linear terms - do i=1,ipenlin sges1=real(sges(1),r_quad) pbc(1,i)=pstart(1,i)-(2.0_r_quad*pstart(2,i)-pstart(3,i)*sges1)*sges1 @@ -475,60 +474,72 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & else it=ibin end if - call stplimq(dval(ibin),sval(ibin),sges,pbcqmin(1,ibin),pbcqmax(1,ibin),nstep,it) - end do - pbc(:,4)=zero_quad - pbc(:,5)=zero_quad - do ibin=1,nobs_bins + call stplimq(dval(ibin),sval(ibin),sges,pbcqmin,pbcqmax,nstep,it) do j=1,nstep - pbc(j,4) = pbc(j,4)+pbcqmin(j,ibin) - pbc(j,5) = pbc(j,5)+pbcqmax(j,ibin) + pbc(j,4) = pbc(j,4)+pbcqmin(j) + pbc(j,5) = pbc(j,5)+pbcqmax(j) end do + if(pjcalc)then + pj(4,ibin)=pj(4,ibin)+pbcqmin(1)+pbcqmin(ipenloc) + pj(5,ibin)=pj(5,ibin)+pbcqmax(1)+pbcqmax(ipenloc) + end if end do - if(pjcalc)then - do ibin=1,nobs_bins - pj(4,ibin)=pj(4,ibin)+pbcqmin(1,ibin)+pbcqmin(ipenloc,ibin) - pj(5,ibin)=pj(5,ibin)+pbcqmax(1,ibin)+pbcqmax(ipenloc,ibin) - end do - end if end if +!$omp parallel sections +!$omp section ! penalties for gust constraint - if(getindex(cvars2d,'gust')>0) & - call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep) - if(pjcalc)pj(6,1)=pbc(1,6)+pbc(ipenloc,6) + if(gustpresent) then + call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep) + if(pjcalc)pj(6,1)=pbc(1,6)+pbc(ipenloc,6) + end if +!$omp section ! penalties for vis constraint - if(getindex(cvars2d,'vis')>0) & - call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep) - if(pjcalc)pj(7,1)=pbc(1,7)+pbc(ipenloc,7) + if(vispresent) then + call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep) + if(pjcalc)pj(7,1)=pbc(1,7)+pbc(ipenloc,7) + end if ! penalties for pblh constraint - if(getindex(cvars2d,'pblh')>0) & - call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep) - if(pjcalc)pj(8,1)=pbc(1,8)+pbc(ipenloc,8) +!$omp section + if(pblhpresent) then + call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep) + if(pjcalc)pj(8,1)=pbc(1,8)+pbc(ipenloc,8) + end if ! penalties for wspd10m constraint - if(getindex(cvars2d,'wspd10m')>0) & - call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep) - if(pjcalc)pj(9,1)=pbc(1,9)+pbc(ipenloc,9) +!$omp section + if(wspd10mpresent) then + call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep) + if(pjcalc)pj(9,1)=pbc(1,9)+pbc(ipenloc,9) + end if ! penalties for howv constraint - if(getindex(cvars2d,'howv')>0) & - call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep) - if(pjcalc)pj(10,1)=pbc(1,10)+pbc(ipenloc,10) +!$omp section + if(howvpresent) then + call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep) + if(pjcalc)pj(10,1)=pbc(1,10)+pbc(ipenloc,10) + end if ! penalties for lcbas constraint - if(getindex(cvars2d,'lcbas')>0) & - call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep) - if(pjcalc)pj(11,1)=pbc(1,11)+pbc(ipenloc,11) +!$omp section + if(lcbaspresent) then + call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep) + if(pjcalc)pj(11,1)=pbc(1,11)+pbc(ipenloc,11) + end if ! penalties for cldch constraint - if(getindex(cvars2d,'cldch')>0) & - call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep) - if(pjcalc)pj(12,1)=pbc(1,12)+pbc(ipenloc,12) +!$omp section + if(cldchpresent) then + call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep) + if(pjcalc)pj(12,1)=pbc(1,12)+pbc(ipenloc,12) + end if +!$omp end parallel sections if (ljclimqc) then - if (getindex(cvars3d,'ql')>0) then +!$omp parallel sections private (ibin,it,j) +!$omp section + if (qlpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,13),nstep,ntguessig,'ql') if(pjcalc) pj(13,1)=pbc(1,13)+pbc(ipenloc,13) @@ -541,7 +552,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcql(1,ibin),nstep,it,'ql') end do - pbc(:,13)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,13) = pbc(j,13)+pbcql(j,ibin) @@ -554,7 +564,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qi')>0) then +!$omp section + if (qipresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,14),nstep,ntguessig,'qi') if(pjcalc) pj(14,1)=pbc(1,14)+pbc(ipenloc,14) @@ -567,7 +578,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqi(1,ibin),nstep,it,'qi') end do - pbc(:,14)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,14) = pbc(j,14)+pbcqi(j,ibin) @@ -580,7 +590,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qr')>0) then +!$omp section + if (qrpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,15),nstep,ntguessig,'qr') if(pjcalc) pj(15,1)=pbc(1,15)+pbc(ipenloc,15) @@ -593,7 +604,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqr(1,ibin),nstep,it,'qr') end do - pbc(:,15)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,15) = pbc(j,15)+pbcqr(j,ibin) @@ -606,7 +616,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qs')>0) then +!$omp section + if (qspresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,16),nstep,ntguessig,'qs') if(pjcalc) pj(16,1)=pbc(1,16)+pbc(ipenloc,16) @@ -619,7 +630,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqs(1,ibin),nstep,it,'qs') end do - pbc(:,16)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,16) = pbc(j,16)+pbcqs(j,ibin) @@ -632,7 +642,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qg')>0) then +!$omp section + if (qgpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,17),nstep,ntguessig,'qg') if(pjcalc) pj(17,1)=pbc(1,17)+pbc(ipenloc,17) @@ -645,7 +656,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqg(1,ibin),nstep,it,'qg') end do - pbc(:,17)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,17) = pbc(j,17)+pbcqg(j,ibin) @@ -658,33 +668,35 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if +!$omp end parallel sections end if ! ljclimqc end if + ! penalties for Jo pbcjoi=zero_quad call stpjo(dval,dbias,sval,sbias,sges,pbcjoi,nstep) pbcjo=zero_quad - do ibin=1,size(pbcjoi,3) ! == obs_bins - do j=1,size(pbcjoi,2) - do i=1,size(pbcjoi,1) + do ibin=1,nobs_bins ! == obs_bins + do j=1,nobs_type + do i=1,4 pbcjo(i,j)=pbcjo(i,j)+pbcjoi(i,j,ibin) end do end do enddo + do j=1,nobs_type + do i=1,4 + pbc(i,n0+j)=pbcjo(i,j) + end do + end do if(pjcalc)then - do ibin=1,size(pbcjoi,3) - do j=1,size(pbcjoi,2) + do ibin=1,nobs_bins + do j=1,nobs_type pj(n0+j,ibin)=pj(n0+j,ibin)+pbcjoi(ipenloc,j,ibin)+pbcjoi(1,j,ibin) end do enddo endif - do j=1,size(pbcjo,2) - do i=1,size(pbcjo,1) - pbc(i,n0+j)=pbcjo(i,j) - end do - end do ! Gather J contributions call mpl_allreduce(4,ipen,pbc) @@ -718,114 +730,93 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! estimate of stepsize + istp_use=ii stp(ii)=stp(ii-1) - if(cx > 1.e-20_r_kind) then - stp(ii)=stp(ii)+bx/cx ! step size estimate - else -! Check for cx <= 0. (probable error or large nonlinearity) - if(mype == 0) then - write(iout_iter,*) ' entering cx <=0 stepsize option',cx,stp(ii) - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - stp(ii)=outstp(ipenloc) - outpensave=outpen(ipenloc) - do i=1,nsteptot - if(outpen(i) < outpensave)then - stp(ii)=outstp(i) - outpensave=outpen(i) - end if - end do - if(outpensave < outpen(ipenloc))then - if(mype == 0)write(iout_iter,*) ' early termination due to cx <=0 ',cx,stp(ii) - cxterm=.true. - else -! Try different (better?) stepsize - stp(ii)=max(outstp(1),1.0e-20_r_kind) - do i=2,nsteptot - if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) - end do - stp(ii)=one_tenth_quad*stp(ii) - change_dels=.false. - end if - end if - + if(cx > 1.e-20_r_quad) stp(ii)=stp(ii)+bx/cx ! step size estimate ! estimate various terms in penalty on first iteration if(ii == 1)then - do i=1,ipen - pen_save(i)=pbc(1,i) - bsum_save(i)=bsum(i) - csum_save(i)=csum(i) - end do - pjcost(1) = pen_save(1)+pbc(ipenloc,1) ! Jb + pjcost(1) = pbc(1,1)+pbc(ipenloc,1) ! Jb pjcost(2) = zero_quad do i=1,nobs_type - pjcost(2) = pjcost(2)+pen_save(n0+i)+pbc(ipenloc,n0+i) ! Jo + pjcost(2) = pjcost(2)+pbc(1,n0+i)+pbc(ipenloc,n0+i) ! Jo end do - pjcost(3) = pen_save(2) + pen_save(3)+pbc(ipenloc,3) ! Jc + pjcost(3) = pbc(1,2) + pbc(1,3)+pbc(ipenloc,3) ! Jc pjcost(4) = zero_quad do i=4,n0 - pjcost(4) = pjcost(4) + pen_save(i)+pbc(ipenloc,i) ! Jl + pjcost(4) = pjcost(4) + pbc(1,i)+pbc(ipenloc,i) ! Jl end do penalty=pjcost(1)+pjcost(2)+pjcost(3)+pjcost(4) ! J = Jb + Jo + Jc +Jl ! Write out detailed results to iout_iter - if(mype == 0) then - write(iout_iter,100) (pen_save(i)+pbc(ipenloc,i),i=1,ipen) - if(print_verbose)then - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - end if - endif - -! estimate of change in penalty - delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx ) - -! If change in penalty is very small end stepsize calculation - if(abs(delpen/penalty) < 1.e-17_r_kind) then - if(mype == 0)then - write(iout_iter,*) ' minimization has converged ' - write(iout_iter,140) ii,delpen,bx,cx,stp(ii) + if(mype == minmype) then write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen) if(print_verbose)then write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) end if end if - end_iter = .true. -! Finalize timer - call timer_fnl('stpcalc') - istp_use=ii - exit stepsize - end if + endif -! Check for negative stepsize (probable error or large nonlinearity) - if(stp(ii) <= zero_quad) then - if(mype == 0) then - write(iout_iter,*) ' entering negative stepsize option',stp(ii) + if(cx <= 1.e-20_r_quad .or. stp(ii) <= zero_quad)then +! Check for cx <= 0 or. stp(ii) < zero. (probable error or large nonlinearity) + if(mype == minmype) then + write(iout_iter,*) ' entering cx <=0 or stp <= 0 stepsize option',cx,stp(ii) write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) end if stp(ii)=outstp(ipenloc) outpensave=outpen(ipenloc) - do i=1,nsteptot + do i=1,ii if(outpen(i) < outpensave)then - stp(ii)=outstp(i) outpensave=outpen(i) + istp_use=i end if end do + if(istp_use /= ii .and. stp(istp_use) > zero_quad)then + if(mype == minmype)then + write(iout_iter,*) ' early termination due to cx or stp <=0 ',cx,stp(ii) + write(iout_iter,*) ' better stepsize found',cx,stp(ii) + end if + exit stepsize + else if(ii == istp_iter)then + if(mype == minmype)then + write(iout_iter,*) ' early termination due to no decrease in penalty ',cx,stp(ii) + end if + stp(istp_use)=zero + end_iter = .true. + exit stepsize + else ! Try different (better?) stepsize - if(stp(ii) <= zero_quad .and. ii /= istp_iter)then - stp(ii)=max(outstp(1),1.0e-20_r_kind) - do i=2,nsteptot - if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) - end do - stp(ii)=one_tenth_quad*stp(ii) - change_dels=.false. + stp(ii)=one_tenth_quad*max(outstp(1),1.0e-20_r_kind) end if + else + +! estimate of change in penalty + delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx ) + +! If change in penalty is very small end stepsize calculation + if(abs(delpen/penalty) < 1.e-17_r_kind) then + if(mype == minmype)then + write(iout_iter,*) ' minimization has converged ' + write(iout_iter,140) ii,delpen,bx,cx,stp(ii) + write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen) + if(print_verbose)then + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) + end if + end if + end_iter = .true. +! Finalize timer + call timer_fnl('stpcalc') + exit stepsize + end if +! Check for convergence in stepsize estimation + stprat(ii)=zero + if(stp(ii) > zero_quad)stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) + if(stprat(ii) < 1.e-4_r_kind) exit stepsize + dels = one_tenth_quad*dels end if 100 format(' J=',3e25.18/,(3x,3e25.18)) @@ -839,31 +830,21 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & 141 format('***WARNING*** reduced penalty not found in search direction',/, & ' - probable error',(5e25.18)) -! Check for convergence in stepsize estimation - istp_use=ii - if(cxterm) exit stepsize - stprat(ii)=zero - if(stp(ii) > zero)then - stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) - end if - if(stprat(ii) < 1.e-4_r_kind) exit stepsize - if(change_dels)dels = one_tenth_quad*dels ! If stepsize estimate has not converged use best stepsize estimate or zero if( ii == istp_iter)then stp(ii)=outstp(ipenloc) outpensave=outpen(ipenloc) - ifound=.false. ! Find best stepsize to this point do i=1,nsteptot if(outpen(i) < outpensave)then stp(ii)=outstp(i) outpensave=outpen(i) - ifound=.true. + istp_use=i end if end do - if(ifound)exit stepsize + if(istp_use /= istp_iter)exit stepsize ! If no best stepsize set to zero and end minimization - if(mype == 0)then + if(mype == minmype)then write(iout_iter,141)(outpen(i),i=1,nsteptot) end if end_iter = .true. @@ -874,39 +855,41 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end do stepsize if(kprt >= 2 .and. iter == 0)then call mpl_allreduce(ipen,nobs_bins,pj) - if(mype == 0)call prnt_j(pj,n0,ipen,kprt) + if(mype == minmype)call prnt_j(pj,n0,ipen,kprt) end if stpinout=stp(istp_use) ! Estimate terms in penalty - if(mype == 0 .and. print_verbose)then - do i=1,ipen - pen_est(i)=pen_save(i)-(stpinout-stp(0))*(2.0_r_quad*bsum_save(i)- & - (stpinout-stp(0))*csum_save(i)) + if(mype == minmype)then + if(print_verbose)then + do i=1,ipen + pen_est(i)=pbc(1,i)-(stpinout-stp(0))*(2.0_r_quad*bsum(i)- & + (stpinout-stp(0))*csum(i)) + end do + write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) + end if + pjcostnew(1) = pbc(1,1) ! Jb + pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc + pjcostnew(4)=zero + do i=4,n0 + pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl end do - write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) - end if - pjcostnew(1) = pbc(1,1) ! Jb - pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc - pjcostnew(4)=zero - do i=4,n0 - pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl - end do - pjcostnew(2) = zero - do i=1,nobs_type - pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo - end do - penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4) + pjcostnew(2) = zero + do i=1,nobs_type + pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo + end do + penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4) - if(mype == 0 .and. print_verbose)then - write(iout_iter,200) (stp(i),i=0,istp_use) - write(iout_iter,199) (stprat(ii),ii=1,istp_use) - write(iout_iter,201) (outstp(i),i=1,nsteptot) - write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) + if(print_verbose)then + write(iout_iter,200) (stp(i),i=0,istp_use) + write(iout_iter,199) (stprat(ii),ii=1,istp_use) + write(iout_iter,201) (outstp(i),i=1,nsteptot) + write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) + end if end if ! Check for final stepsize negative (probable error) if(stpinout <= zero)then - if(mype == 0)then + if(mype == minmype)then write(iout_iter,130) ii,bx,cx,stp(ii) write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) @@ -926,19 +909,22 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & endif ! Update solution - do i=1,nrclen - sbias%values(i)=sbias%values(i)+stpinout*dbias%values(i) - end do !$omp parallel do schedule(dynamic,1) private(i,ii) - do ii=1,nobs_bins - do i=1,sval(ii)%ndim - sval(ii)%values(i)=sval(ii)%values(i)+stpinout*dval(ii)%values(i) - end do - end do -!DIR$ IVDEP - do i=1,nclen - xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i) - yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i) + do ii=1,nobs_bins+2 + if(ii <= nobs_bins)then + do i=1,sval(ii)%ndim + sval(ii)%values(i)=sval(ii)%values(i)+stpinout*dval(ii)%values(i) + end do + else if(ii == nobs_bins+1)then + do i=1,nrclen + sbias%values(i)=sbias%values(i)+stpinout*dbias%values(i) + end do + else + do i=1,nclen + xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i) + yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i) + end do + end if end do @@ -975,6 +961,7 @@ subroutine prnt_j(pj,n0,ipen,kprt) use mpimod, only: mype use gsi_obOperTypeManager, only: nobs_type => obOper_count use gsi_obOperTypeManager, only: obOper_typeInfo + use gridmod, only: minmype real(r_quad),dimension(ipen,nobs_bins),intent(in ) :: pj integer(i_kind) ,intent(in ) :: n0,ipen,kprt @@ -986,7 +973,7 @@ subroutine prnt_j(pj,n0,ipen,kprt) integer(i_kind) :: ii,jj character(len=20) :: ctype(ipen) - if(kprt <=0 .or. mype /=0)return + if(kprt <=0 .or. mype /=minmype)return ctype(:)=".unknown." ctype(1)='background ' ctype(2)=' ' diff --git a/src/gsi/stpgps.f90 b/src/gsi/stpgps.f90 index f55e9f4292..d357df1c05 100644 --- a/src/gsi/stpgps.f90 +++ b/src/gsi/stpgps.f90 @@ -107,12 +107,13 @@ subroutine stpgps(gpshead,rval,sval,out,sges,nstep) real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges ! Declare local variables - integer(i_kind) j,kk,ier,istatus - integer(i_kind),dimension(nsig):: i1,i2,i3,i4 + integer(i_kind):: j,kk,ier,istatus + integer(i_kind):: i1,i2,i3,i4 real(r_kind) :: val,val2 real(r_kind) :: w1,w2,w3,w4 real(r_kind) :: q_TL,p_TL,t_TL real(r_kind) :: rq_TL,rp_TL,rt_TL + real(r_kind),dimension(nsig) :: valk2,valk real(r_kind),pointer,dimension(:) :: st,sq real(r_kind),pointer,dimension(:) :: rt,rq real(r_kind),pointer,dimension(:) :: sp @@ -149,34 +150,33 @@ subroutine stpgps(gpshead,rval,sval,out,sges,nstep) val2=-gpsptr%res if(nstep > 0)then - do j=1,nsig - i1(j)= gpsptr%ij(1,j) - i2(j)= gpsptr%ij(2,j) - i3(j)= gpsptr%ij(3,j) - i4(j)= gpsptr%ij(4,j) - enddo w1=gpsptr%wij(1) w2=gpsptr%wij(2) w3=gpsptr%wij(3) w4=gpsptr%wij(4) - val=zero - - +!$omp parallel do schedule(dynamic,1) private(j,t_TL,rt_TL,q_TL,rq_TL,p_TL,rp_TL,i1,i2,i3,i4) do j=1,nsig - t_TL =w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j)) - rt_TL=w1* rt(i1(j))+w2* rt(i2(j))+w3* rt(i3(j))+w4* rt(i4(j)) - q_TL =w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j)) - rq_TL=w1* rq(i1(j))+w2* rq(i2(j))+w3* rq(i3(j))+w4* rq(i4(j)) - p_TL =w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j)) - rp_TL=w1* rp(i1(j))+w2* rp(i2(j))+w3* rp(i3(j))+w4* rp(i4(j)) - val2 = val2 + t_tl*gpsptr%jac_t(j)+ q_tl*gpsptr%jac_q(j)+p_tl*gpsptr%jac_p(j) - val = val + rt_tl*gpsptr%jac_t(j)+rq_tl*gpsptr%jac_q(j)+rp_tl*gpsptr%jac_p(j) - + i1= gpsptr%ij(1,j) + i2= gpsptr%ij(2,j) + i3= gpsptr%ij(3,j) + i4= gpsptr%ij(4,j) + t_TL =w1* st(i1)+w2* st(i2)+w3* st(i3)+w4* st(i4) + rt_TL=w1* rt(i1)+w2* rt(i2)+w3* rt(i3)+w4* rt(i4) + q_TL =w1* sq(i1)+w2* sq(i2)+w3* sq(i3)+w4* sq(i4) + rq_TL=w1* rq(i1)+w2* rq(i2)+w3* rq(i3)+w4* rq(i4) + p_TL =w1* sp(i1)+w2* sp(i2)+w3* sp(i3)+w4* sp(i4) + rp_TL=w1* rp(i1)+w2* rp(i2)+w3* rp(i3)+w4* rp(i4) + valk2(j) = t_tl*gpsptr%jac_t(j)+ q_tl*gpsptr%jac_q(j)+ p_tl*gpsptr%jac_p(j) + valk(j) = rt_tl*gpsptr%jac_t(j)+rq_tl*gpsptr%jac_q(j)+rp_tl*gpsptr%jac_p(j) enddo - + val=zero + do j=1,nsig + val2 = val2 + valk2(j) + val = val + valk(j) + enddo ! penalty and gradient do kk=1,nstep diff --git a/src/gsi/stpjo.f90 b/src/gsi/stpjo.f90 index b0ff730823..0f80d9b4a2 100644 --- a/src/gsi/stpjo.f90 +++ b/src/gsi/stpjo.f90 @@ -267,8 +267,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) use m_obsdiags, only: obOper_destroy use gsi_obOperTypeManager, only: obOper_typeInfo - use intradmod, only: setrad - use mpeu_util, only: perr,die use mpeu_util, only: tell use mpeu_mpif, only: MPI_comm_world @@ -290,7 +288,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) class(obOper),pointer:: it_obOper !************************************************************************************ - call setrad(xval(1)) !$omp parallel do schedule(dynamic,1) private(ll,mm,ib,it_obOper) do mm=1,stpcnt diff --git a/src/gsi/stprad.f90 b/src/gsi/stprad.f90 index 0def855d61..e81688f7e3 100644 --- a/src/gsi/stprad.f90 +++ b/src/gsi/stprad.f90 @@ -110,7 +110,7 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) use gsi_metguess_mod, only: gsi_metguess_get use mpeu_util, only: getindex use intradmod, only: luseu,lusev,luset,luseq,lusecw,luseoz,luseqg,luseqh,luseqi,luseql, & - luseqr,luseqs + luseqr,luseqs,lusesst use intradmod, only: itsen,iqv,ioz,icw,ius,ivs,isst,iqg,iqh,iqi,iql,iqr,iqs,lgoback use m_obsNode, only: obsNode use m_radNode, only: radNode @@ -128,14 +128,15 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) type(gsi_bundle),intent(in) :: xval ! Declare local variables - integer(i_kind) istatus - integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk, mm, ic1,ncr + integer(i_kind) istatus,icx + integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk,mm,ncr real(r_kind) val2,val,w1,w2,w3,w4 real(r_kind),dimension(nsigradjac):: tdir,rdir real(r_kind) cg_rad,wgross,wnotgross integer(i_kind),dimension(nsig) :: j1n,j2n,j3n,j4n - real(r_kind),dimension(max(1,nstep)) :: term,rad + real(r_kind),dimension(max(1,nstep)) :: rad type(radNode), pointer :: radptr + real(r_kind),allocatable,dimension(:,:) :: term real(r_kind),allocatable,dimension(:) :: biasvects real(r_kind),allocatable,dimension(:) :: biasvectr real(r_kind),pointer,dimension(:) :: rt,rq,rcw,roz,ru,rv,rqg,rqh,rqi,rql,rqr,rqs @@ -150,34 +151,59 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) if(lgoback)return -! Retrieve pointers - call gsi_bundlegetpointer(xval,'u', su, istatus) - call gsi_bundlegetpointer(xval,'v', sv, istatus) - call gsi_bundlegetpointer(xval,'tsen' ,st, istatus) - call gsi_bundlegetpointer(xval,'q', sq, istatus) - call gsi_bundlegetpointer(xval,'cw' ,scw,istatus) - call gsi_bundlegetpointer(xval,'oz' ,soz,istatus) - call gsi_bundlegetpointer(xval,'sst',sst,istatus) - call gsi_bundlegetpointer(xval,'qg' ,sqg,istatus) - call gsi_bundlegetpointer(xval,'qh' ,sqh,istatus) - call gsi_bundlegetpointer(xval,'qi' ,sqi,istatus) - call gsi_bundlegetpointer(xval,'ql' ,sql,istatus) - call gsi_bundlegetpointer(xval,'qr' ,sqr,istatus) - call gsi_bundlegetpointer(xval,'qs' ,sqs,istatus) - - call gsi_bundlegetpointer(dval,'u', ru, istatus) - call gsi_bundlegetpointer(dval,'v', rv, istatus) - call gsi_bundlegetpointer(dval,'tsen' ,rt, istatus) - call gsi_bundlegetpointer(dval,'q', rq, istatus) - call gsi_bundlegetpointer(dval,'cw' ,rcw,istatus) - call gsi_bundlegetpointer(dval,'oz' ,roz,istatus) - call gsi_bundlegetpointer(dval,'sst',rst,istatus) - call gsi_bundlegetpointer(dval,'qg' ,rqg,istatus) - call gsi_bundlegetpointer(dval,'qh' ,rqh,istatus) - call gsi_bundlegetpointer(dval,'qi' ,rqi,istatus) - call gsi_bundlegetpointer(dval,'ql' ,rql,istatus) - call gsi_bundlegetpointer(dval,'qr' ,rqr,istatus) - call gsi_bundlegetpointer(dval,'qs' ,rqs,istatus) +! Retrieve pointers for used variables + if(luseu)then + call gsi_bundlegetpointer(dval,'u', ru, istatus) + call gsi_bundlegetpointer(xval,'u', su, istatus) + end if + if(lusev)then + call gsi_bundlegetpointer(xval,'v', sv, istatus) + call gsi_bundlegetpointer(dval,'v', rv, istatus) + end if + if(luset)then + call gsi_bundlegetpointer(xval,'tsen' ,st, istatus) + call gsi_bundlegetpointer(dval,'tsen' ,rt, istatus) + end if + if(luseq)then + call gsi_bundlegetpointer(xval,'q', sq, istatus) + call gsi_bundlegetpointer(dval,'q', rq, istatus) + end if + if(lusecw)then + call gsi_bundlegetpointer(xval,'cw' ,scw,istatus) + call gsi_bundlegetpointer(dval,'cw' ,rcw,istatus) + end if + if(luseoz)then + call gsi_bundlegetpointer(xval,'oz' ,soz,istatus) + call gsi_bundlegetpointer(dval,'oz' ,roz,istatus) + end if + if(lusesst)then + call gsi_bundlegetpointer(xval,'sst',sst,istatus) + call gsi_bundlegetpointer(dval,'sst',rst,istatus) + end if + if(luseqg)then + call gsi_bundlegetpointer(xval,'qg' ,sqg,istatus) + call gsi_bundlegetpointer(dval,'qg' ,rqg,istatus) + end if + if(luseqh)then + call gsi_bundlegetpointer(xval,'qh' ,sqh,istatus) + call gsi_bundlegetpointer(dval,'qh' ,rqh,istatus) + end if + if(luseqi)then + call gsi_bundlegetpointer(xval,'qi' ,sqi,istatus) + call gsi_bundlegetpointer(dval,'qi' ,rqi,istatus) + end if + if(luseql)then + call gsi_bundlegetpointer(xval,'ql' ,sql,istatus) + call gsi_bundlegetpointer(dval,'ql' ,rql,istatus) + end if + if(luseqr)then + call gsi_bundlegetpointer(xval,'qr' ,sqr,istatus) + call gsi_bundlegetpointer(dval,'qr' ,rqr,istatus) + end if + if(luseqs)then + call gsi_bundlegetpointer(xval,'qs' ,sqs,istatus) + call gsi_bundlegetpointer(dval,'qs' ,rqs,istatus) + end if tdir=zero @@ -187,118 +213,117 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) do while(associated(radptr)) if(radptr%luse)then if(nstep > 0)then - j1=radptr%ij(1) - j2=radptr%ij(2) - j3=radptr%ij(3) - j4=radptr%ij(4) w1=radptr%wij(1) w2=radptr%wij(2) w3=radptr%wij(3) w4=radptr%wij(4) - if(luseu)then - tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4) - rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4) - endif - if(lusev)then - tdir(ivs+1)=w1* sv(j1) + w2* sv(j2) + w3* sv(j3) + w4* sv(j4) - rdir(ivs+1)=w1* rv(j1) + w2* rv(j2) + w3* rv(j3) + w4* rv(j4) - endif - if (isst>=0) then - tdir(isst+1)=w1*sst(j1) + w2*sst(j2) + w3*sst(j3) + w4*sst(j4) - rdir(isst+1)=w1*rst(j1) + w2*rst(j2) + w3*rst(j3) + w4*rst(j4) - end if - j1n(1) = j1 - j2n(1) = j2 - j3n(1) = j3 - j4n(1) = j4 + j1n(1) = radptr%ij(1) + j2n(1) = radptr%ij(2) + j3n(1) = radptr%ij(3) + j4n(1) = radptr%ij(4) do n=2,nsig j1n(n) = j1n(n-1)+latlon11 j2n(n) = j2n(n-1)+latlon11 j3n(n) = j3n(n-1)+latlon11 j4n(n) = j4n(n-1)+latlon11 enddo - do n=1,nsig - j1 = j1n(n) - j2 = j2n(n) - j3 = j3n(n) - j4 = j4n(n) - -! Input state vector -! Input search direction vector - if(luset)then - tdir(itsen+n)=w1* st(j1) +w2* st(j2) + w3* st(j3) +w4* st(j4) - rdir(itsen+n)=w1* rt(j1) +w2* rt(j2) + w3* rt(j3) +w4* rt(j4) - endif - if(luseq)then - tdir(iqv+n)=w1* sq(j1) +w2* sq(j2) + w3* sq(j3) +w4* sq(j4) - rdir(iqv+n)=w1* rq(j1) +w2* rq(j2) + w3* rq(j3) +w4* rq(j4) - endif - if (luseoz) then - tdir(ioz+n)=w1*soz(j1)+w2*soz(j2)+ w3*soz(j3)+w4*soz(j4) - rdir(ioz+n)=w1*roz(j1)+w2*roz(j2)+ w3*roz(j3)+w4*roz(j4) - end if - if (lusecw) then - tdir(icw+n)=w1*scw(j1)+w2*scw(j2)+ w3*scw(j3)+w4*scw(j4) - rdir(icw+n)=w1*rcw(j1)+w2*rcw(j2)+ w3*rcw(j3)+w4*rcw(j4) - end if - if (luseqg) then - tdir(iqg+n)=w1*sqg(j1)+w2*sqg(j2)+ w3*sqg(j3)+w4*sqg(j4) - rdir(iqg+n)=w1*rqg(j1)+w2*rqg(j2)+ w3*rqg(j3)+w4*rqg(j4) - end if - if (luseqh) then - tdir(iqh+n)=w1*sqh(j1)+w2*sqh(j2)+ w3*sqh(j3)+w4*sqh(j4) - rdir(iqh+n)=w1*rqh(j1)+w2*rqh(j2)+ w3*rqh(j3)+w4*rqh(j4) - end if - if (luseqi) then - tdir(iqi+n)=w1*sqi(j1)+w2*sqi(j2)+ w3*sqi(j3)+w4*sqi(j4) - rdir(iqi+n)=w1*rqi(j1)+w2*rqi(j2)+ w3*rqi(j3)+w4*rqi(j4) - end if - if (luseql) then - tdir(iql+n)=w1*sql(j1)+w2*sql(j2)+ w3*sql(j3)+w4*sql(j4) - rdir(iql+n)=w1*rql(j1)+w2*rql(j2)+ w3*rql(j3)+w4*rql(j4) - end if - if (luseqr) then - tdir(iqr+n)=w1*sqr(j1)+w2*sqr(j2)+ w3*sqr(j3)+w4*sqr(j4) - rdir(iqr+n)=w1*rqr(j1)+w2*rqr(j2)+ w3*rqr(j3)+w4*rqr(j4) + allocate(biasvects(radptr%nchan)) + allocate(biasvectr(radptr%nchan)) + allocate(term(max(1,nstep),radptr%nchan)) + +!$omp parallel do schedule(dynamic,1) private(n,j1,j2,j3,j4,icx,vals_quad,valr_quad,nx) + do n=1,max(nsig,radptr%nchan) + if(n <= nsig)then + j1 = j1n(n) + j2 = j2n(n) + j3 = j3n(n) + j4 = j4n(n) + if(n == 1)then + if(luseu)then + tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4) + rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4) + endif + if(lusev)then + tdir(ivs+1)=w1* sv(j1) + w2* sv(j2) + w3* sv(j3) + w4* sv(j4) + rdir(ivs+1)=w1* rv(j1) + w2* rv(j2) + w3* rv(j3) + w4* rv(j4) + endif + if (lusesst) then + tdir(isst+1)=w1*sst(j1) + w2*sst(j2) + w3*sst(j3) + w4*sst(j4) + rdir(isst+1)=w1*rst(j1) + w2*rst(j2) + w3*rst(j3) + w4*rst(j4) + end if + end if + +! Input state vector +! Input search direction vector + if(luset)then + tdir(itsen+n)=w1* st(j1) +w2* st(j2) + w3* st(j3) +w4* st(j4) + rdir(itsen+n)=w1* rt(j1) +w2* rt(j2) + w3* rt(j3) +w4* rt(j4) + endif + if(luseq)then + tdir(iqv+n)=w1* sq(j1) +w2* sq(j2) + w3* sq(j3) +w4* sq(j4) + rdir(iqv+n)=w1* rq(j1) +w2* rq(j2) + w3* rq(j3) +w4* rq(j4) + endif + if (luseoz) then + tdir(ioz+n)=w1*soz(j1)+w2*soz(j2)+ w3*soz(j3)+w4*soz(j4) + rdir(ioz+n)=w1*roz(j1)+w2*roz(j2)+ w3*roz(j3)+w4*roz(j4) + end if + if (lusecw) then + tdir(icw+n)=w1*scw(j1)+w2*scw(j2)+ w3*scw(j3)+w4*scw(j4) + rdir(icw+n)=w1*rcw(j1)+w2*rcw(j2)+ w3*rcw(j3)+w4*rcw(j4) + end if + if (luseqg) then + tdir(iqg+n)=w1*sqg(j1)+w2*sqg(j2)+ w3*sqg(j3)+w4*sqg(j4) + rdir(iqg+n)=w1*rqg(j1)+w2*rqg(j2)+ w3*rqg(j3)+w4*rqg(j4) + end if + if (luseqh) then + tdir(iqh+n)=w1*sqh(j1)+w2*sqh(j2)+ w3*sqh(j3)+w4*sqh(j4) + rdir(iqh+n)=w1*rqh(j1)+w2*rqh(j2)+ w3*rqh(j3)+w4*rqh(j4) + end if + if (luseqi) then + tdir(iqi+n)=w1*sqi(j1)+w2*sqi(j2)+ w3*sqi(j3)+w4*sqi(j4) + rdir(iqi+n)=w1*rqi(j1)+w2*rqi(j2)+ w3*rqi(j3)+w4*rqi(j4) + end if + if (luseql) then + tdir(iql+n)=w1*sql(j1)+w2*sql(j2)+ w3*sql(j3)+w4*sql(j4) + rdir(iql+n)=w1*rql(j1)+w2*rql(j2)+ w3*rql(j3)+w4*rql(j4) + end if + if (luseqr) then + tdir(iqr+n)=w1*sqr(j1)+w2*sqr(j2)+ w3*sqr(j3)+w4*sqr(j4) + rdir(iqr+n)=w1*rqr(j1)+w2*rqr(j2)+ w3*rqr(j3)+w4*rqr(j4) + end if + if (luseqs) then + tdir(iqs+n)=w1*sqs(j1)+w2*sqs(j2)+ w3*sqs(j3)+w4*sqs(j4) + rdir(iqs+n)=w1*rqs(j1)+w2*rqs(j2)+ w3*rqs(j3)+w4*rqs(j4) + end if end if - if (luseqs) then - tdir(iqs+n)=w1*sqs(j1)+w2*sqs(j2)+ w3*sqs(j3)+w4*sqs(j4) - rdir(iqs+n)=w1*rqs(j1)+w2*rqs(j2)+ w3*rqs(j3)+w4*rqs(j4) + if(n <= radptr%nchan)then + icx=radptr%icx(n) + vals_quad = zero_quad + valr_quad = zero_quad + do nx=1,npred + vals_quad = vals_quad + spred(nx,icx)*radptr%pred(nx,n) + valr_quad = valr_quad + rpred(nx,icx)*radptr%pred(nx,n) + end do + biasvects(n) = vals_quad + biasvectr(n) = valr_quad end if - end do - end if - if(nstep > 0)then - allocate(biasvects(radptr%nchan)) - allocate(biasvectr(radptr%nchan)) - do nn=1,radptr%nchan - ic1=radptr%icx(nn) - vals_quad = zero_quad - valr_quad = zero_quad - do nx=1,npred - vals_quad = vals_quad + spred(nx,ic1)*radptr%pred(nx,nn) - valr_quad = valr_quad + rpred(nx,ic1)*radptr%pred(nx,nn) - end do - biasvects(nn) = vals_quad - biasvectr(nn) = valr_quad - end do endif - ncr=0 +! !$omp parallel do schedule(dynamic,1) private(nn,ic,mm,ncr,k,kk,rad,val,val2,cg_rad,wnotgross,wgross) do nn=1,radptr%nchan - val2=-radptr%res(nn) - if(nstep > 0)then val = zero + val2=-radptr%res(nn) ! contribution from bias corection ic=radptr%icx(nn) if(radptr%use_corr_obs) then do mm=1,nn - ncr=ncr+1 + ncr=radptr%iccerr(nn)+mm val2=val2+radptr%rsqrtinv(ncr)*biasvects(mm) val =val +radptr%rsqrtinv(ncr)*biasvectr(mm) end do @@ -318,12 +343,12 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) rad(kk)=val2+sges(kk)*val end do else - rad(kk)= val2 + rad(1)= -radptr%res(nn) end if ! calculate contribution to J do kk=1,max(1,nstep) - term(kk) = radptr%err2(nn)*rad(kk)*rad(kk) + term(kk,nn) = radptr%err2(nn)*rad(kk)*rad(kk) end do ! Modify penalty term if nonlinear QC @@ -333,18 +358,23 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) wnotgross= one-pg_rad(ic)*varqc_iter wgross = varqc_iter*pg_rad(ic)*cg_rad/wnotgross do kk=1,max(1,nstep) - term(kk) = -two*log((exp(-half*term(kk) ) + wgross)/(one+wgross)) + term(kk,nn) = -two*log((exp(-half*term(kk,nn) ) + wgross)/(one+wgross)) end do endif - out(1) = out(1) + term(1)*radptr%raterr2(nn) + end do + + deallocate(biasvects, biasvectr) + + do nn=1,radptr%nchan + out(1) = out(1) + term(1,nn)*radptr%raterr2(nn) do kk=2,nstep - out(kk) = out(kk) + (term(kk)-term(1))*radptr%raterr2(nn) + out(kk) = out(kk) + (term(kk,nn)-term(1,nn))*radptr%raterr2(nn) end do end do - if(nstep > 0) deallocate(biasvects, biasvectr) + deallocate(term) end if diff --git a/src/gsi/stprw.f90 b/src/gsi/stprw.f90 index 710d9baa23..c5f996463c 100644 --- a/src/gsi/stprw.f90 +++ b/src/gsi/stprw.f90 @@ -83,6 +83,7 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) ! !$$$ use kinds, only: r_kind,i_kind,r_quad + use obsmod, only: if_use_w_vr use qcmod, only: nlnqc_iter,varqc_iter use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600 use gsi_bundlemod, only: gsi_bundle @@ -124,7 +125,7 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) call gsi_bundlegetpointer(sval,'u',su,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'v',sv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'w',sw,istatus) - if (istatus==0) then + if (if_use_w_vr.and.istatus==0) then include_w=.true. else include_w=.false. @@ -132,7 +133,7 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) call gsi_bundlegetpointer(rval,'u',ru,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'v',rv,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'w',rw,istatus) - if (istatus==0) then + if (if_use_w_vr.and.istatus==0) then include_w=.true. else include_w=.false. diff --git a/src/gsi/stpsst.f90 b/src/gsi/stpsst.f90 index 222b67862c..765676010b 100644 --- a/src/gsi/stpsst.f90 +++ b/src/gsi/stpsst.f90 @@ -101,13 +101,13 @@ subroutine stpsst(ssthead,rval,sval,out,sges,nstep) real(r_kind) pg_sst real(r_kind),pointer,dimension(:) :: ssst real(r_kind),pointer,dimension(:) :: rsst - real(r_kind) tdir,rdir type(sstNode), pointer :: sstptr out=zero_quad ! If no sst data return if(.not. associated(ssthead))return + if(.not. nst_gsi > 2 ) return ! Retrieve pointers ! Simply return if any pointer not found @@ -129,15 +129,12 @@ subroutine stpsst(ssthead,rval,sval,out,sges,nstep) w3=sstptr%wij(3) w4=sstptr%wij(4) - if ( nst_gsi > 2 .and. (sstptr%tz_tr > zero .and. sstptr%tz_tr <= one) ) then - tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) - rdir = w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) - val = sstptr%tz_tr*rdir - val2 = sstptr%tz_tr*tdir - sstptr%res - else - val =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) - val2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)-sstptr%res - endif + val =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) + val2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) + + val = sstptr%tz_tr*val + val2 = sstptr%tz_tr*val2 + val2=val2-sstptr%res do kk=1,nstep sst=val2+sges(kk)*val diff --git a/src/gsi/stpt.f90 b/src/gsi/stpt.f90 index 27f5385ac1..5911d87b9d 100644 --- a/src/gsi/stpt.f90 +++ b/src/gsi/stpt.f90 @@ -184,7 +184,6 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) w6=tptr%wij(6) w7=tptr%wij(7) w8=tptr%wij(8) -! Note time derivative stuff not consistent for virtual temperature if(tptr%tv_ob)then val= w1*rtv(j1)+w2*rtv(j2)+w3*rtv(j3)+w4*rtv(j4)+ & @@ -208,9 +207,6 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) end do end if - do kk=1,nstep - tt(kk)=val2+sges(kk)*val - end do if(tptr%use_sfc_model) then @@ -229,8 +225,9 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) valv2=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) valp =w1* rp(j1)+w2* rp(j2)+w3* rp(j3)+w4* rp(j4) valp2=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) + do kk=1,nstep - ts_prime=tt(kk) + ts_prime=val2+sges(kk)*val tg_prime=valsst2+sges(kk)*valsst qs_prime=valq2+sges(kk)*valq us_prime=valu2+sges(kk)*valu @@ -239,14 +236,18 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) tt(kk)=psfc_prime*tptr%tlm_tsfc(1) + tg_prime*tptr%tlm_tsfc(2) + & ts_prime *tptr%tlm_tsfc(3) + qs_prime*tptr%tlm_tsfc(4) + & - us_prime *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6) + us_prime *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6) - & + tptr%res + end do + + else + + do kk=1,nstep + tt(kk)=val2+sges(kk)*val-tptr%res end do end if - do kk=1,nstep - tt(kk)=tt(kk)-tptr%res - end do else tt(1)=tptr%res end if diff --git a/src/gsi/stub_wrf_binary_interface.f90 b/src/gsi/stub_wrf_binary_interface.f90 index 201482df13..58ef9e004e 100644 --- a/src/gsi/stub_wrf_binary_interface.f90 +++ b/src/gsi/stub_wrf_binary_interface.f90 @@ -29,18 +29,26 @@ end subroutine convert_binary_mass_dummy subroutine convert_binary_nmm_dummy(this,update_pint,ctph0,stph0,tlm0) use kinds, only: r_kind + use constants, only: zero implicit none class(get_wrf_binary_interface_class), intent(inout) :: this logical ,intent(inout) :: update_pint real(r_kind),intent( out) :: ctph0,stph0,tlm0 + ctph0 = zero + stph0 = zero + tlm0 = zero end subroutine convert_binary_nmm_dummy subroutine convert_nems_nmmb_dummy(this,update_pint,ctph0,stph0,tlm0) use kinds, only: r_kind + use constants, only: zero implicit none class(get_wrf_binary_interface_class), intent(inout) :: this logical ,intent(inout) :: update_pint real(r_kind),intent( out) :: ctph0,stph0,tlm0 + ctph0 = zero + stph0 = zero + tlm0 = zero end subroutine convert_nems_nmmb_dummy end module get_wrf_binary_interface_mod diff --git a/src/gsi/stub_wrf_netcdf_interface.f90 b/src/gsi/stub_wrf_netcdf_interface.f90 index d80b765300..4235318686 100644 --- a/src/gsi/stub_wrf_netcdf_interface.f90 +++ b/src/gsi/stub_wrf_netcdf_interface.f90 @@ -30,12 +30,15 @@ end subroutine convert_netcdf_mass_dummy subroutine convert_netcdf_nmm_dummy(this,update_pint,ctph0,stph0,tlm0,guess) use kinds, only: r_single,i_kind,r_kind + use constants, only: zero implicit none class(convert_netcdf_class) ,intent(inout) :: this logical ,intent(in ) :: guess logical ,intent(inout) :: update_pint real(r_kind),intent( out) :: ctph0,stph0,tlm0 - + ctph0 = zero + stph0 = zero + tlm0 = zero end subroutine convert_netcdf_nmm_dummy subroutine update_netcdf_mass_dummy(this) diff --git a/src/gsi/update_guess.f90 b/src/gsi/update_guess.f90 index e5a0f64245..1885542a1b 100644 --- a/src/gsi/update_guess.f90 +++ b/src/gsi/update_guess.f90 @@ -113,7 +113,7 @@ subroutine update_guess(sval,sbias) use mpimod, only: mype use constants, only: zero,one,fv,max_varname_length,qmin,qcmin,tgmin,& r100,one_tenth,tiny_r_kind - use jfunc, only: iout_iter,bcoption,tsensible,clip_supersaturation,superfact + use jfunc, only: iout_iter,bcoption,tsensible,clip_supersaturation,superfact,hofx_2m_sfcfile use gridmod, only: lat2,lon2,nsig,& regional,twodvar_regional,regional_ozone,& l_reg_update_hydro_delz @@ -458,7 +458,7 @@ subroutine update_guess(sval,sbias) endif call gsd_update_soil_tq(tinc_1st,is_t,qinc_1st,is_q,it) endif ! l_gsd_soilTQ_nudge - if (i_use_2mt4b > 0 .and. is_t>0) then + if ( (i_use_2mt4b > 0.or. hofx_2m_sfcfile) .and. is_t>0) then do j=1,lon2 do i=1,lat2 tinc_1st(i,j)=p_tv(i,j,1) @@ -466,7 +466,7 @@ subroutine update_guess(sval,sbias) end do call gsd_update_t2m(tinc_1st,it) endif ! l_gsd_t2m_adjust - if (i_use_2mq4b > 0 .and. is_q>0) then + if ( (i_use_2mq4b > 0.or. hofx_2m_sfcfile) .and. is_q>0) then do j=1,lon2 do i=1,lat2 qinc_1st(i,j)=p_q(i,j,1) diff --git a/src/gsi/vqc_int.f90 b/src/gsi/vqc_int.f90 index 714ee23ea3..12abc53b35 100644 --- a/src/gsi/vqc_int.f90 +++ b/src/gsi/vqc_int.f90 @@ -27,12 +27,12 @@ subroutine vqc_int(error2,rat_error2,t_pgv,cg_tv,var_jbv,ibv,ikv,valv,gradv) real(r_kind), intent(out) :: gradv ! Declare local variables - real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq + real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq - if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. & + if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. & cg_tv > tiny_r_kind) then wnotgross= one-t_pgv wgross =t_pgv*cg_tv/wnotgross diff --git a/src/gsi/vqc_stp.f90 b/src/gsi/vqc_stp.f90 index 1c8f296853..04d9a91245 100644 --- a/src/gsi/vqc_stp.f90 +++ b/src/gsi/vqc_stp.f90 @@ -41,7 +41,7 @@ subroutine vqc_stp(pen_v,nstep_v,tpg_v,cgt_v,& ! Note: if wgross=0 (no gross error, then wnotgross=1 and this ! all reduces to the linear case (no qc) - if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then + if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then wnotgross= one-tpg_v wgross =tpg_v*cgt_v/wnotgross do kk=1,max(1,nstep_v) diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90 index 69ad96e281..9adb150863 100644 --- a/src/gsi/write_incr.f90 +++ b/src/gsi/write_incr.f90 @@ -26,7 +26,7 @@ module write_incr contains - subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) + subroutine write_fv3_inc_ (grd,filename,mype_out,gfs_bundle,ibin) !$$$ subprogram documentation block ! . . . @@ -76,6 +76,7 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) use general_sub2grid_mod, only: sub2grid_info use gsi_bundlemod, only: gsi_bundle, gsi_bundlegetpointer + use gsi_bundlemod, only: assignment(=) use control_vectors, only: control_vector use constants, only: one, rad2deg, r1000 @@ -93,13 +94,13 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) use state_vectors, only: svars3d use mpeu_util, only: getindex + use control2state_mod, only: control2state implicit none ! !INPUT PARAMETERS: type(sub2grid_info), intent(in) :: grd - type(spec_vars), intent(in) :: sp_a character(len=24), intent(in) :: filename ! file to open and write to integer(i_kind), intent(in) :: mype_out ! mpi task to write output file type(gsi_bundle), intent(in) :: gfs_bundle @@ -158,7 +159,6 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) ! set up state space based off of xhatsave ! Convert from control space directly to physical ! space for comparison with obs. - call allocate_preds(sbiasinc) do iii=1,nobs_bins call allocate_state(svalinc(iii)) end do @@ -168,7 +168,10 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) do iii=1,ntlevs_ens call allocate_state(evalinc(iii)) end do + + call allocate_preds(sbiasinc) call control2state(xhatsave,mvalinc,sbiasinc) + call deallocate_preds(sbiasinc) if (l4dvar) then if (l_hyb_ens) then @@ -193,6 +196,12 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) end do end if end if + do iii=1,ntlevs_ens + call deallocate_state(evalinc(iii)) + end do + do iii=1,nsubwin + call deallocate_state(mvalinc(iii)) + end do ! Check hydrometeors in control variables iql = getindex(svars3d,'ql') @@ -366,10 +375,9 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) ncstart = (/ jstart(mype+1), 1, 1 /) nccount = (/ grd%lon1, grd%lat1-1, grd%nsig /) j1 = 2 - j2 = grd%lat1-1 else if (istart(mype+1)+grd%lat1 == grd%nlat+1) then nccount = (/ grd%lon1, grd%lat1-1, grd%nsig /) - j2 = grd%lat1-2 + j2 = grd%lat1-1 end if call mpi_barrier(mpi_comm_world,ierror) allocate(out3d(nccount(1),nccount(2),grd%nsig)) @@ -528,6 +536,10 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) endif ! ! cleanup and exit call nccheck_incr(nf90_close(ncid_out)) + deallocate(out3d) + do iii=1,nobs_bins + call deallocate_state(svalinc(iii)) + end do if ( mype == mype_out ) then write(6,*) "FV3 netCDF increment written, file= "//trim(filename)//".nc" end if diff --git a/src/gsi/xhat_vordivmod.f90 b/src/gsi/xhat_vordivmod.f90 index bff52aa9d4..e271fb9fb3 100644 --- a/src/gsi/xhat_vordivmod.f90 +++ b/src/gsi/xhat_vordivmod.f90 @@ -77,6 +77,8 @@ subroutine init_ allocate(xhat_vor(lat2,lon2,nsig,nobs_bins)) allocate(xhat_div(lat2,lon2,nsig,nobs_bins)) + xhat_vor=zero + xhat_div=zero end subroutine init_ subroutine clean_ @@ -146,18 +148,6 @@ subroutine calc_(sval) !******************************************************************************* -! Initialize local arrays - do ii=1,nobs_bins - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - xhat_vor(i,j,k,ii) = zero - xhat_div(i,j,k,ii) = zero - end do - end do - end do - end do - ! The GSI analyzes stream function (sf) and velocity potential (vp). ! Wind field observations are in terms of zonal (u) and meridional ! (v) wind components or wind speed. Thus, the GSI carries wind diff --git a/ush/build_4nco_global.sh b/ush/build_4nco_global.sh index 60382ce9b5..45d5eaf7a1 100755 --- a/ush/build_4nco_global.sh +++ b/ush/build_4nco_global.sh @@ -18,6 +18,9 @@ export GSI_MODE="GFS" export ENKF_MODE="GFS" export REGRESSION_TESTS="NO" +# Optionally set compiler flags +##export FFLAGS="-check all,noarg_temp_created" + # Prune the directory structure per NCO liking if [[ "${PRUNE_4NCO:-}" =~ [yYtT] ]]; then $DIR_ROOT/ush/prune_4nco_global.sh prune diff --git a/ush/prune_4nco_global.sh b/ush/prune_4nco_global.sh index 0e1eba2ead..149d2bab50 100755 --- a/ush/prune_4nco_global.sh +++ b/ush/prune_4nco_global.sh @@ -15,6 +15,8 @@ # removed directories and files # +function version { echo "$@" | awk -F. '{ printf("%d%03d%03d%03d\n", $1,$2,$3,$4); }'; } + set -ex mode=$1 @@ -23,7 +25,14 @@ mode=$1 if [[ "$mode" = "prune" ]]; then string="rm -r" elif [[ "$mode" = "restore" ]]; then - string="reset HEAD" + git_ver=$(git version | cut -d" " -f3) + if [ $(version $git_ver) -lt $(version "2.23.0") ]; then + use_checkout="YES" + string="checkout" + else + use_checkout="NO" + string="restore" + fi else echo " " echo "***ERROR*** invalid mode= $mode" @@ -46,38 +55,58 @@ echo " " cd $topdir rlist="regression src/GSD unit-tests" for type in $rlist; do - git $string ${type}* - rc=$? - if [[ $rc -ne 0 ]]; then - echo "***ERROR* git $string ${type}" - exit - fi - if [[ "$mode" = "restore" ]]; then - git checkout ${type}* - rc=$? - if [[ $rc -ne 0 ]]; then - echo "***ERROR* git checkout ${type}" + if [[ "$mode" = "prune" ]]; then + if [ -e $type ]; then + git $string ${type}* + rc=$? + if [[ $rc -ne 0 ]]; then + echo "***ERROR*** git $string ${type}" + exit + fi + fi + elif [[ "$mode" = "restore" ]]; then + if [[ "$use_checkout" = "YES" ]]; then + git reset HEAD ${type}* + git checkout ${type}* + rc=$? + else + git restore --staged ${type}* + git restore ${type}* + rc=$? + fi + if [[ $rc -ne 0 ]]; then + echo "***ERROR*** restore failed for ${type}" exit - fi + fi fi done # Process doc directories and files cd $topdir/doc -rlist="EnKF_user_guide GSI_user_guide README.discover" +rlist="EnKF_user_guide GSI_user_guide README.discover Release_Notes.fv3gfs_da.v15.0.0.txt Release_Notes.gfsda.v16.0.0.txt" for type in $rlist; do - git $string ${type}* - rc=$? - if [[ $rc -ne 0 ]]; then - echo "***ERROR* git $string ${type}" - exit - fi - if [[ "$mode" = "restore" ]]; then - git checkout ${type}* - rc=$? + if [[ "$mode" = "prune" ]]; then + if [ -e $type ]; then + git $string ${type}* + rc=$? + if [[ $rc -ne 0 ]]; then + echo "***ERROR*** git $string ${type}" + exit + fi + fi + elif [[ "$mode" = "restore" ]]; then + if [[ "$use_checkout" = "YES" ]]; then + git reset HEAD ${type}* + git checkout ${type}* + rc=$? + else + git restore --staged ${type}* + git restore ${type}* + rc=$? + fi if [[ $rc -ne 0 ]]; then - echo "***ERROR* git checkout ${type}" + echo "***ERROR*** restore failed for ${type}" exit fi fi @@ -88,17 +117,27 @@ done cd $topdir/ush rlist="sub" for type in $rlist; do - git $string ${type}* - rc=$? - if [[ $rc -ne 0 ]]; then - echo "***ERROR* git $string ${type}" - exit - fi - if [[ "$mode" = "restore" ]]; then - git checkout ${type}* - rc=$? + if [[ "$mode" = "prune" ]]; then + if [ -e $type ]; then + git $string ${type}* + rc=$? + if [[ $rc -ne 0 ]]; then + echo "***ERROR*** git $string ${type}" + exit + fi + fi + elif [[ "$mode" = "restore" ]]; then + if [[ "$use_checkout" = "YES" ]]; then + git reset HEAD ${type}* + git checkout ${type}* + rc=$? + else + git restore --staged ${type}* + git restore ${type}* + rc=$? + fi if [[ $rc -ne 0 ]]; then - echo "***ERROR* git checkout ${type}" + echo "***ERROR*** restore failed for ${type}" exit fi fi diff --git a/ush/sub_jet b/ush/sub_jet index 5bd9a6d68c..e11be1280c 100755 --- a/ush/sub_jet +++ b/ush/sub_jet @@ -88,7 +88,7 @@ output=${output:-$jobname.out} myuser=$LOGNAME myhost=$(hostname) -DATA=$regdir/regtests/data +DATA=${DATA:-$ptmp/tmp} mkdir -p $DATA @@ -117,6 +117,7 @@ echo "#SBATCH --time=$timew" echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile #echo "#SBATCH -j oe" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile +echo "#SBATCH --mem=0" >> $cfile echo "#SBATCH --partition=kjet" >> $cfile #echo "#SBATCH -V" >> $cfile #echo "#PBS -d" >> $cfile