From df010e4e68effe73116aa9758080ef0f50ed5d37 Mon Sep 17 00:00:00 2001 From: ClaraDraper-NOAA <33430543+ClaraDraper-NOAA@users.noreply.github.com> Date: Thu, 2 Mar 2023 11:38:25 -0700 Subject: [PATCH 01/17] Bugfix in EnKF assim of conventional q obs (#545) **Description** Added code to divide hx_modens by qsat, for consistency with treatment of q as q/qsat. Fixes issue #544 --- src/enkf/readconvobs.f90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index e1977298a6..f3b1e38f04 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -789,6 +789,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 From 723a034248448e31979abda063f8895ac3f9c918 Mon Sep 17 00:00:00 2001 From: David Huber <69919478+DavidHuber-NOAA@users.noreply.github.com> Date: Thu, 9 Mar 2023 10:24:13 -0500 Subject: [PATCH 02/17] Update Jet support (#537) --- modulefiles/gsi_jet.lua | 24 +++++++++++++++--------- regression/global_3dvar.sh | 2 +- regression/regression_param.sh | 16 ++++++++-------- regression/regression_var.sh | 9 +++------ ush/sub_jet | 3 ++- 5 files changed, 29 insertions(+), 25 deletions(-) diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua index ddb255bc1f..855597a08e 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/20221128") whatis("Description: GSI environment on Jet with Intel Compilers") 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/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..98083c8587 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" @@ -138,19 +138,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." 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 From 89c47116ef0f931f16b5bb5a3380fb58b9d87a1a Mon Sep 17 00:00:00 2001 From: emilyhcliu <36091766+emilyhcliu@users.noreply.github.com> Date: Tue, 14 Mar 2023 12:36:09 -0400 Subject: [PATCH 03/17] gfsda.v16 merge with develop (#526) merge changes made in recent GFS v16.3.x implementations into develop --- modulefiles/gsi_common.lua | 2 +- regression/netcdf_fv3_regional.sh | 9 --- regression/regression_var.sh | 12 --- src/gsi/aircraftinfo.f90 | 2 +- src/gsi/cplr_gfs_ensmod.f90 | 31 ++++---- src/gsi/general_read_gfsatm.f90 | 1 + src/gsi/gesinfo.F90 | 10 +-- src/gsi/netcdfgfs_io.f90 | 2 +- src/gsi/radinfo.f90 | 6 +- src/gsi/read_diag.f90 | 4 +- src/gsi/read_files.f90 | 8 +- src/gsi/read_prepbufr.f90 | 12 ++- src/gsi/read_satwnd.f90 | 19 ++--- src/gsi/setuprad.f90 | 2 +- src/gsi/setupw.f90 | 15 ++-- src/gsi/stub_wrf_binary_interface.f90 | 8 ++ src/gsi/stub_wrf_netcdf_interface.f90 | 5 +- src/gsi/write_incr.f90 | 3 +- ush/build_4nco_global.sh | 3 + ush/prune_4nco_global.sh | 107 ++++++++++++++++++-------- 20 files changed, 146 insertions(+), 115 deletions(-) diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua index 6844372324..b2b08f1197 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.2" 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/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_var.sh b/regression/regression_var.sh index 98083c8587..8733a341e2 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -173,18 +173,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/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/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index c16c0e8c0e..dc55bcaf9e 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -385,7 +385,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) 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 @@ -440,31 +440,31 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! 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 @@ -938,9 +938,8 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig ! 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 diff --git a/src/gsi/general_read_gfsatm.f90 b/src/gsi/general_read_gfsatm.f90 index 39db75db73..0216b95fb6 100755 --- a/src/gsi/general_read_gfsatm.f90 +++ b/src/gsi/general_read_gfsatm.f90 @@ -2825,6 +2825,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z 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 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/netcdfgfs_io.f90 b/src/gsi/netcdfgfs_io.f90 index ce32e13554..e1255b773c 100644 --- a/src/gsi/netcdfgfs_io.f90 +++ b/src/gsi/netcdfgfs_io.f90 @@ -1300,7 +1300,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/radinfo.f90 b/src/gsi/radinfo.f90 index 76a08c39a5..8bfb015d1c 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 @@ -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_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_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index d2cb503926..f992ace329 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -475,7 +475,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 @@ -2239,8 +2239,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 +3057,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..c67d5a7e1f 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) @@ -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/setuprad.f90 b/src/gsi/setuprad.f90 index 8d0d343fb0..479d27af96 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -1816,7 +1816,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 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/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/write_incr.f90 b/src/gsi/write_incr.f90 index 69ad96e281..e312199998 100644 --- a/src/gsi/write_incr.f90 +++ b/src/gsi/write_incr.f90 @@ -366,10 +366,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)) 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 From 31b8b29a098fd8df50a9f0b11c6912d47ae0628c Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Thu, 16 Mar 2023 14:10:49 -0400 Subject: [PATCH 04/17] remove and update non crtm/2.4.0 references (#551) --- ci/spack.yaml | 2 +- modulefiles/gsi_gaea | 3 --- regression/regression_var.sh | 4 ---- 3 files changed, 1 insertion(+), 8 deletions(-) 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/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/regression/regression_var.sh b/regression/regression_var.sh index 8733a341e2..05b5563ef1 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -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" @@ -160,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" From 89ca542c963c7887494e728656515918ce7a8518 Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Sat, 18 Mar 2023 01:39:18 +0900 Subject: [PATCH 05/17] GitHub Issue NOAA-EMC/GSI#538 Add options to tune weights of mixed ensemble for FV3-LAM EnVar (#541) This PR adds options (weight_ens_gfs and weight_ens_fv3sar) to tune weights of mixed ensemble for FV3-LAM EnVar (https://github.com/NOAA-EMC/GSI/issues/538). Regression tests for global 3dvar/4denvar/4dvar are not completed yet, but for other tests, issues are not found except for "failed the scalability test" and "exceeded maximum allowable hardware memory limit" on Orion. Fixes #538 Co-authored-by: Sho Yokota --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 4 ++-- src/gsi/get_gefs_for_regional.f90 | 4 ++-- src/gsi/gsimod.F90 | 8 +++++--- src/gsi/hybrid_ensemble_parameters.f90 | 4 ++++ 4 files changed, 13 insertions(+), 7 deletions(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 6e94b29c6c..fb4afe121d 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 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/gsimod.F90 b/src/gsi/gsimod.F90 index 8ccef7c38e..a86c20880c 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -154,7 +154,7 @@ module gsimod i_ensloccov4tim,i_ensloccov4var,i_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, & @@ -1408,7 +1408,8 @@ 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, & @@ -1821,7 +1822,8 @@ subroutine gsimain_initialize else 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 diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 index 17416f68fb..d813541c7a 100644 --- a/src/gsi/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -287,6 +287,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 @@ -361,6 +362,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 @@ -497,6 +499,8 @@ 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 vdl_scale = 0 vloc_varlist = 'aaa' global_spectral_filter_sd=.false. From 4afe6edba0ba830173ff97c9ac8b3fbfd17e0e21 Mon Sep 17 00:00:00 2001 From: chunhua zhou Date: Fri, 24 Mar 2023 13:12:29 -0600 Subject: [PATCH 06/17] Add dDZ for EnKF (#536) **Description** This update includes several functions added for dBZ analysis in EnKF: 1, Add dBZ ncdiag output for EnKF analysis 2, Enhanced binary dBZ diag output for EnKF analysis 3, Fix spurious analysis increments when assimilating reflectivity (from OU MAP) 4, Added EnKF interface for read in dBZ from FV3LAM ensemble forecast (from OU MAP) Fixed a bug for read in subdomain surface restart files Fixes #534 --- src/enkf/enkf.f90 | 41 +++++++++++-- src/enkf/gridinfo_fv3reg.f90 | 4 +- src/enkf/gridio_fv3reg.f90 | 109 +++++++++++++++++++++++++++++------ src/gsi/gsi_dbzOper.F90 | 23 +++++++- src/gsi/gsi_rfv3io_mod.f90 | 75 +++++++++++------------- src/gsi/setupdbz.f90 | 10 ++-- 6 files changed, 191 insertions(+), 71 deletions(-) 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/gridio_fv3reg.f90 b/src/enkf/gridio_fv3reg.f90 index fb23a21a0c..4939dd16ee 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 ! @@ -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,6 +690,7 @@ 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) @@ -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 @@ -1006,6 +1054,25 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid 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 + if (ps_ind > 0) then allocate(workprsi(nx_res,ny_res,nlevsp1)) allocate(pswork(nx_res,ny_res)) @@ -1051,7 +1118,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),& @@ -2478,19 +2546,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 +2581,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/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_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 2edde4723f..7e7b11d57c 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 ! @@ -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 @@ -3300,6 +3292,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/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 ) From 113e30778a6b4401404507f7d40fe99b60fbc2b6 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Tue, 28 Mar 2023 11:27:50 -0400 Subject: [PATCH 07/17] Use prod ncio and ncdiag on wcoss2 (#554) **Description** The ncio and ncdiag modules have been promoted from para to prod on WCOSS2. This PR replaces the para load of these modules with prod on WCOSS2. Fixes #554 --- modulefiles/gsi_wcoss2.lua | 9 --------- 1 file changed, 9 deletions(-) diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.lua index 84ffce874a..209af8c8a9 100644 --- a/modulefiles/gsi_wcoss2.lua +++ b/modulefiles/gsi_wcoss2.lua @@ -19,15 +19,6 @@ 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") From 14ae595af1b03471287d322596d35c0665336e95 Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Mon, 3 Apr 2023 21:27:33 +0900 Subject: [PATCH 08/17] GitHub Issue NOAA-EMC/GSI#539 Add options to tune cross-scale/variable/time covariances in EnVar (#542) This PR modifies options (i_ensloccov4{scl,var,tim} -> r_ensloccov4{scl,var,tim}) to tune cross-scale/variable/time covariances in EnVar (https://github.com/NOAA-EMC/GSI/issues/539). Regression tests for global 3dvar/4denvar/4dvar are not completed yet, but for other tests, issues are not found except for "failed the scalability test" and "exceeded maximum allowable hardware memory limit" on Orion. Fixes #539 Co-authored-by: Sho Yokota --- src/gsi/apply_scaledepwgts.f90 | 6 ++--- src/gsi/gsimod.F90 | 31 +++++++++++++---------- src/gsi/hybrid_ensemble_isotropic.F90 | 35 ++++++-------------------- src/gsi/hybrid_ensemble_parameters.f90 | 35 ++++++++++++++++---------- 4 files changed, 50 insertions(+), 57 deletions(-) diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90 index 62c455e011..8b93cf0b57 100644 --- a/src/gsi/apply_scaledepwgts.f90 +++ b/src/gsi/apply_scaledepwgts.f90 @@ -47,7 +47,7 @@ subroutine init_mult_spc_wgts(jcap_in) 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: zero,half,one,two,three,rearth,pi,tiny_r_kind use constants, only: rad2deg use mpimod, only: mype use general_sub2grid_mod, only: general_sub2grid_create_info @@ -55,7 +55,7 @@ subroutine init_mult_spc_wgts(jcap_in) 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 @@ -68,7 +68,7 @@ subroutine init_mult_spc_wgts(jcap_in) integer(i_kind) :: l_sum_spc_weights ! Spectral scale decomposition is differernt between SDL-cross and SDL-nocross - if( i_ensloccov4scl == 1 )then + if( r_ensloccov4scl < tiny_r_kind )then l_sum_spc_weights = 1 else l_sum_spc_weights = 0 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index a86c20880c..c4317dbd2c 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -151,7 +151,7 @@ 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,weight_ens_gfs,weight_ens_fv3sar @@ -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', @@ -1415,7 +1420,7 @@ module gsimod 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 diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 7e74b3ec27..7b133ffb5a 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -5553,7 +5553,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 +5596,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 d813541c7a..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 !===================================================================================================== ! ! @@ -326,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 @@ -395,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 @@ -501,6 +507,9 @@ subroutine init_hybrid_ensemble_parameters 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. From 1661c15183a388742d67baf70621c93773f5830f Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Fri, 14 Apr 2023 18:22:00 -0400 Subject: [PATCH 09/17] Fix write_incr (#559) --- src/gsi/write_incr.f90 | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90 index e312199998..b22be8de30 100644 --- a/src/gsi/write_incr.f90 +++ b/src/gsi/write_incr.f90 @@ -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 @@ -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') @@ -527,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 From 48ea34a9afbcec7b41e44dcd3cdf656bc1d49503 Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Tue, 9 May 2023 13:10:46 -0400 Subject: [PATCH 10/17] Optimize GSI (#527) --- src/gsi/adjtest.f90 | 30 +- src/gsi/adjtest_obs.f90 | 1 + src/gsi/aeroinfo.f90 | 8 +- src/gsi/atms_spatial_average_mod.f90 | 2 +- src/gsi/bicg.f90 | 10 +- src/gsi/bicglanczos.F90 | 11 +- src/gsi/bkerror.f90 | 7 +- src/gsi/calctends_no_tl.f90 | 13 +- src/gsi/compact_diffs.f90 | 62 +- src/gsi/constants.f90 | 2 +- src/gsi/control2state.f90 | 646 +++++++-- src/gsi/control2state_ad.f90 | 441 ------ src/gsi/control_vectors.f90 | 55 +- src/gsi/convthin.f90 | 94 +- src/gsi/convthin_time.f90 | 114 +- src/gsi/correlated_obsmod.F90 | 99 +- src/gsi/cplr_gfs_ensmod.f90 | 462 +++---- src/gsi/cplr_gfs_nstmod.f90 | 262 ++-- src/gsi/cwhydromod.f90 | 73 +- src/gsi/deter_sfc_mod.f90 | 7 +- src/gsi/evaljgrad.f90 | 2 + src/gsi/genqsat.f90 | 6 +- src/gsi/get_gefs_ensperts_dualres.f90 | 134 +- src/gsi/getsiga.f90 | 1 + src/gsi/gridmod.F90 | 11 +- src/gsi/gsi_files.cmake | 1 - src/gsi/gsimod.F90 | 2 +- src/gsi/hybrid_ensemble_isotropic.F90 | 12 +- src/gsi/intall.f90 | 41 +- src/gsi/intgps.f90 | 19 +- src/gsi/intjcmod.f90 | 19 +- src/gsi/intjo.f90 | 3 - src/gsi/intrad.f90 | 226 ++-- src/gsi/intsst.f90 | 38 +- src/gsi/intt.f90 | 61 +- src/gsi/jgrad.f90 | 1 + src/gsi/lightinfo.f90 | 12 +- src/gsi/m_radNode.F90 | 7 +- src/gsi/ncepgfs_io.f90 | 4 +- src/gsi/obs_sensitivity.f90 | 1 + src/gsi/obsmod.F90 | 6 +- src/gsi/pcgsoi.f90 | 92 +- src/gsi/pvqc.f90 | 4 +- src/gsi/q_diag.f90 | 4 +- src/gsi/qcmod.f90 | 124 +- src/gsi/radinfo.f90 | 2 +- src/gsi/read_atms.f90 | 4 +- src/gsi/read_bufrtovs.f90 | 29 +- src/gsi/read_gps.f90 | 6 +- src/gsi/read_iasi.f90 | 67 +- src/gsi/read_obs.F90 | 15 +- src/gsi/read_satwnd.f90 | 2 +- src/gsi/setupcldtot.F90 | 2 +- src/gsi/setuppcp.f90 | 3 +- src/gsi/setuprad.f90 | 391 +++--- src/gsi/state_vectors.f90 | 99 +- src/gsi/statsconv.f90 | 1801 +++++++++++++------------ src/gsi/statslight.f90 | 70 +- src/gsi/statsrad.f90 | 8 +- src/gsi/stpcalc.f90 | 363 +++-- src/gsi/stpgps.f90 | 42 +- src/gsi/stpjo.f90 | 3 - src/gsi/stprad.f90 | 278 ++-- src/gsi/stpsst.f90 | 17 +- src/gsi/stpt.f90 | 19 +- src/gsi/vqc_int.f90 | 4 +- src/gsi/vqc_stp.f90 | 2 +- src/gsi/write_incr.f90 | 4 +- src/gsi/xhat_vordivmod.f90 | 14 +- 69 files changed, 3192 insertions(+), 3283 deletions(-) delete mode 100644 src/gsi/control2state_ad.f90 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/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..ea41b36c46 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 + 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..99629b8aff 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,7 +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) dx,dy,dp + real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -510,13 +501,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 +526,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 +540,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 +549,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 +570,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 +578,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 +603,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_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index dc55bcaf9e..67f15ebae2 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 hybrid_ensemble_parameters, only: n_ens,grd_ens + use gsi_bundlemod, only : assignment(=) + use hybrid_ensemble_parameters, only: n_ens,grd_ens,ntlevs_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 @@ -195,16 +204,11 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & character(len=70) :: filenamesfc integer(i_kind) :: i,ii,j,jj,k,n integer(i_kind) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens - integer(i_kind) :: ip,ips,ipe,jps,jpe - 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,7 +296,7 @@ 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) @@ -295,43 +307,41 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & 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 + if(mas == mae)deallocate(en_full) + -! transfer en_loc to en_loc3 then to atm_bundle +! call genex_destroy_info(s_a2b) ! check on actual routine name - allocate(en_loc3(lat2in,lon2in,nc2d+nc3d*nsig)) - 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 +357,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 +371,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,10 +383,10 @@ 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_' @@ -389,13 +397,14 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) 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 +414,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 +438,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,13 +446,6 @@ 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 - km1 = en_perts(1,1,1)%grid%km - 1 !$omp parallel do schedule(dynamic,1) private(m) do m=1,nc3d @@ -477,7 +483,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 +503,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 +526,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 +546,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 +584,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 +608,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 +634,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 +718,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 +798,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 +808,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 +849,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 +882,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 +904,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 @@ -968,9 +954,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)) @@ -978,90 +975,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) @@ -1069,13 +1001,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 @@ -1094,6 +1033,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) @@ -1103,6 +1043,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 @@ -1115,6 +1056,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) @@ -1147,7 +1089,6 @@ subroutine fillpoles_ss_(temp,nlon,nlat) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero,one implicit none @@ -1157,6 +1098,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 @@ -1167,13 +1109,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_ @@ -1205,13 +1147,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 @@ -1266,7 +1207,6 @@ subroutine move1_(work,temp,nlon,nlat) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero implicit none @@ -1316,7 +1256,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 @@ -1420,7 +1359,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 @@ -1483,7 +1421,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 @@ -1515,7 +1452,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/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/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index 1cb7586a89..fab95ad210 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 @@ -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/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_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/gsimod.F90 b/src/gsi/gsimod.F90 index c4317dbd2c..c8ce5a45be 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -1825,7 +1825,7 @@ 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 diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 7b133ffb5a..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' 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/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/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/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..bb317d0752 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 @@ -831,7 +831,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 8bfb015d1c..ffc4641696 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -1741,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 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_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..d0a3793b4e 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,49 @@ 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)) + 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 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 +829,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 +842,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_satwnd.f90 b/src/gsi/read_satwnd.f90 index c67d5a7e1f..7a372b9e15 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -1206,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 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/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/setuprad.f90 b/src/gsi/setuprad.f90 index 479d27af96..faa79f0efc 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 @@ -560,10 +560,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. @@ -847,25 +846,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 @@ -886,9 +866,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 @@ -996,29 +997,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& tsavg5=tsavg5+dtsavg endif -! If using adaptive angle dependent bias correction, update the predicctors -! for this part of bias correction. The AMSUA cloud liquid water algorithm -! uses total angle dependent bias correction for channels 1 and 2 - if (adp_anglebc) then - do i=1,nchanl - mm=ich(i) - if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then - pred(npred,i)=nadir*deg2rad - else - pred(npred,i)=data_s(iscan_ang,n) - end if - do j=2,angord - pred(npred-j+1,i)=pred(npred,i)**j - end do - cbias(nadir,mm)=zero - if (iuse_rad(mm)/=4) then - do j=1,angord - cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) - end do - end if - end do - end if - ! Compute microwave cloud liquid water or graupel water path for bias correction and QC. clw_obs=zero clw_guess_retrieval=zero @@ -1056,10 +1034,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 @@ -1083,10 +1059,28 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero - cld_rbc_idx2=zero +!$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) - +! 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 + if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then + pred(npred,i)=nadir*deg2rad + else + pred(npred,i)=data_s(iscan_ang,n) + end if + do j=2,angord + pred(npred-j+1,i)=pred(npred,i)**j + end do + cbias(nadir,mm)=zero + if (iuse_rad(mm)/=4) then + do j=1,angord + cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) + end do + end if + end if !***** ! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES @@ -1115,28 +1109,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 @@ -1234,15 +1207,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) @@ -1258,19 +1253,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 @@ -1323,17 +1318,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 @@ -1365,14 +1360,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, & @@ -1464,14 +1455,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 @@ -1490,9 +1477,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 @@ -1500,15 +1485,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 -------------- @@ -1526,14 +1511,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 @@ -1549,14 +1530,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 @@ -1570,7 +1547,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 @@ -1675,20 +1651,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 @@ -1699,60 +1684,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 @@ -1767,39 +1747,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 @@ -1813,6 +1790,13 @@ 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 @@ -1843,18 +1827,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 @@ -1888,7 +1868,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 @@ -1899,12 +1879,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 @@ -1950,7 +1929,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) @@ -2018,6 +1997,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. @@ -2112,23 +2098,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/state_vectors.f90 b/src/gsi/state_vectors.f90 index 711043fa57..ffad280bf5 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 @@ -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..2d79fd3e3b 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,91 @@ 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 + write(iout_iter,*) ' early termination due to no decrease in penalty ',cx,stp(ii) + 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 +828,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 +853,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 +907,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 +959,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 +971,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..20fe0dd1a9 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/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/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 b22be8de30..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 ! . . . @@ -94,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 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 From 726cc8dc16279b204deb146b584296246a7eb182 Mon Sep 17 00:00:00 2001 From: emilyhcliu <36091766+emilyhcliu@users.noreply.github.com> Date: Fri, 19 May 2023 14:42:03 -0400 Subject: [PATCH 11/17] Enhancement to handle hydrometeors in the EnKF I/O interface (#499) The enhancements made to the EnKF IO interface are the following: (1) For enkf I/O: add the handling of precipitation hydrometeors to parallel netcdf I.O --- preparation of next implementation --- src/enkf/gridio_gfs.f90 | 399 ++++++++++++++++++++++++++++++++-------- 1 file changed, 319 insertions(+), 80 deletions(-) diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index fe5199e395..456f8126e2 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -157,7 +157,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 +185,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 +198,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 +218,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 +250,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 +279,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 +293,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 - 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(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 + 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 +449,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 @@ -3709,7 +3806,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 +3841,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 @@ -3846,6 +3944,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", & @@ -3874,11 +3978,14 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! old logical massbal_adjust, if non-zero use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. & qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 ) + ! Currently, we do not let precipiation to affect the enkf analysis + ! The following line will be removed after testing + use_full_hydro = .false. 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 +3994,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 +4104,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 +4129,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,39 +4201,171 @@ 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)) - ! liq wat increment - ! icmr increment - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - ug = zero - if (cw_ind > 0) then - call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) - end if - if (imp_physics == 11) then - work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c) - do i=1,nlons*nlats - work(i) = max(zero,work(i)) - work(i) = min(one,work(i)) - enddo - vg = ug * work ! cloud ice - ug = ug * (one - work) ! cloud water - inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) + ! 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 + + if (use_full_hydro) then + ! liq wat increment + 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 - inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) - enddo - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) - end do - if (should_zero_increments_for('icmr_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (ql_ind > 0) then + call copyfromgrdin(grdin(:,levels(ql_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 clwmr 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)) + + ! icmr increment + call read_vardata(dsfg, 'icmr', q, 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 + inc(:) = zero + if (qi_ind > 0) then + call copyfromgrdin(grdin(:,levels(qi_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 icmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('icmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! 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)) + else + ! liq wat increment + ! icmr increment + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug = zero + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) + end if + if (imp_physics == 11) then + work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c) + do i=1,nlons*nlats + work(i) = max(zero,work(i)) + work(i) = min(one,work(i)) + enddo + vg = ug * work ! cloud ice + ug = ug * (one - work) ! cloud water + inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) + endif + inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) + enddo + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) + end do + if (should_zero_increments_for('icmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + endif call mpi_barrier(iocomms(mem_pe(nproc)), iret) From ac1a8cbdfa25014549b25fc38b6539b57c494f72 Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Tue, 30 May 2023 11:28:42 -0400 Subject: [PATCH 12/17] Issue with global mean weight for multiscale ensemble runs for ig > 1 plus changes to make code work for multiscale (bugs introduced in develop). (#570) --- src/gsi/apply_scaledepwgts.f90 | 58 +++++++++------------- src/gsi/control_vectors.f90 | 2 +- src/gsi/convthin.f90 | 3 +- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 9 ++-- src/gsi/cplr_gfs_ensmod.f90 | 9 ++-- src/gsi/general_specmod.f90 | 2 +- src/gsi/get_gefs_ensperts_dualres.f90 | 2 +- src/gsi/gsi_rfv3io_mod.f90 | 7 +-- src/gsi/read_dbz_nc.f90 | 2 +- src/gsi/read_iasi.f90 | 4 +- src/gsi/setuprad.f90 | 51 ++++++++++--------- src/gsi/state_vectors.f90 | 2 +- src/gsi/stpcalc.f90 | 4 +- src/gsi/stprad.f90 | 2 +- 14 files changed, 74 insertions(+), 83 deletions(-) diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90 index 8b93cf0b57..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,tiny_r_kind - use constants, only: rad2deg 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,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( r_ensloccov4scl < tiny_r_kind )then - l_sum_spc_weights = 1 + 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/control_vectors.f90 b/src/gsi/control_vectors.f90 index ea41b36c46..97578124d2 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -895,7 +895,7 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) 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 + if(l_hyb_ens)itot=itot+n_ens*naensgrp allocate(partsum(itot)) do ii=1,nsubwin !$omp parallel do schedule(dynamic,1) private(i) diff --git a/src/gsi/convthin.f90 b/src/gsi/convthin.f90 index 99629b8aff..3a52188d73 100644 --- a/src/gsi/convthin.f90 +++ b/src/gsi/convthin.f90 @@ -464,8 +464,7 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io real(r_kind) dlat1,dlon1,pob1 real(r_kind) dx,dy,dp - real(r_kind) dxx,dyy,dpp - real(r_kind) crit!,dist1 + real(r_kind) crit !,dist1 logical foreswp, aftswp diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index fb4afe121d..5a3e72970d 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -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 67f15ebae2..550f85d209 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -180,7 +180,7 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & 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,ntlevs_ens + 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 @@ -202,7 +202,7 @@ 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 integer(i_kind) :: nlon,nlat,nsig @@ -301,6 +301,8 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & 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) @@ -314,7 +316,7 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & allocate(en_loc(ibsm:ibemz,jbsm:jbemz,kbsm:kbemz,mbsm:mbemz)) call genex(s_a2b,en_full,en_loc) - if(mas == mae)deallocate(en_full) + deallocate(en_full) ! call genex_destroy_info(s_a2b) ! check on actual routine name @@ -921,6 +923,7 @@ 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 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/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index fab95ad210..e244fa9f53 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -95,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. & diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 7e7b11d57c..4fcb2aba1d 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -1824,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 @@ -2774,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 @@ -2994,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 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_iasi.f90 b/src/gsi/read_iasi.f90 index d0a3793b4e..208b333f49 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -720,7 +720,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& !$omp parallel do schedule(dynamic,1) private(i,sc_chan,bufr_chan,radiance) channel_loop: do i=1,satinfo_nchan bufr_chan = bufr_index(i) - if (bufr_chan /= 0 ) then + 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)*scalef(bufr_chan) @@ -729,8 +729,6 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& else temperature(bufr_chan) = tbmin endif - else - temperature(bufr_chan) = tbmin end if end do channel_loop diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index faa79f0efc..822ec8ea22 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -998,6 +998,29 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& 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 + do i=1,nchanl + mm=ich(i) + if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then + pred(npred,i)=nadir*deg2rad + else + pred(npred,i)=data_s(iscan_ang,n) + end if + do j=2,angord + pred(npred-j+1,i)=pred(npred,i)**j + end do + cbias(nadir,mm)=zero + if (iuse_rad(mm)/=4) then + do j=1,angord + cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) + end do + end if + end do + end if +!***** clw_obs=zero clw_guess_retrieval=zero gwp=zero @@ -1059,28 +1082,13 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero + abi2km_bc = zero + abi2km_bc(2) = 233.5_r_kind + abi2km_bc(3) = 241.7_r_kind + abi2km_bc(4) = 250.5_r_kind !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) -! 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 - if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then - pred(npred,i)=nadir*deg2rad - else - pred(npred,i)=data_s(iscan_ang,n) - end if - do j=2,angord - pred(npred-j+1,i)=pred(npred,i)**j - end do - cbias(nadir,mm)=zero - if (iuse_rad(mm)/=4) then - do j=1,angord - cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) - end do - end if - end if !***** ! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES @@ -1107,6 +1115,7 @@ 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 @@ -1156,10 +1165,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 diff --git a/src/gsi/state_vectors.f90 b/src/gsi/state_vectors.f90 index ffad280bf5..df332303b0 100644 --- a/src/gsi/state_vectors.f90 +++ b/src/gsi/state_vectors.f90 @@ -386,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 diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index 2d79fd3e3b..30387341e3 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -781,7 +781,9 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if exit stepsize else if(ii == istp_iter)then - write(iout_iter,*) ' early termination due to no decrease in penalty ',cx,stp(ii) + 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 diff --git a/src/gsi/stprad.f90 b/src/gsi/stprad.f90 index 20fe0dd1a9..e81688f7e3 100644 --- a/src/gsi/stprad.f90 +++ b/src/gsi/stprad.f90 @@ -313,7 +313,7 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) endif -!$omp parallel do schedule(dynamic,1) private(nn,ic,mm,ncr,k,kk,rad,val,val2,cg_rad,wnotgross,wgross) +! !$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 if(nstep > 0)then From d766977d72203bd9406b491c131ef84ec3b7139b Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Fri, 2 Jun 2023 02:21:11 +0900 Subject: [PATCH 13/17] GitHub Issue NOAA-EMC/GSI#540 Modify to assimilate radar reflectivity and conventional data simultaneously without side effects in EnVar (#543) This PR removes forcing pure EnVar and adding an option (if_use_w_vr) to assimilate radar reflectivity and conventional data simultaneously without side effects in EnVar (https://github.com/NOAA-EMC/GSI/issues/540). Regression tests for global 3dvar/4denvar/4dvar are not completed yet, but for other tests, issues are not found except for "failed the scalability test" and "exceeded maximum allowable hardware memory limit" on Orion. Fixes #540 Co-authored-by: Sho Yokota --- src/gsi/gsimod.F90 | 14 ++++++++------ src/gsi/intrw.f90 | 6 +++--- src/gsi/obsmod.F90 | 5 +++-- src/gsi/setuprw.f90 | 4 ++-- src/gsi/stprw.f90 | 5 +++-- 5 files changed, 19 insertions(+), 15 deletions(-) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index c8ce5a45be..ed4bbb1e55 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 @@ -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,& @@ -2045,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/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/obsmod.F90 b/src/gsi/obsmod.F90 index bb317d0752..3066cdb5ca 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -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" 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/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. From 57ddc31054e79c8b12e748e5407c43c15d5ffe1f Mon Sep 17 00:00:00 2001 From: ClaraDraper-NOAA <33430543+ClaraDraper-NOAA@users.noreply.github.com> Date: Mon, 5 Jun 2023 13:51:08 -0600 Subject: [PATCH 14/17] Initial changes for GFS v17 soil moisture and temperature analysis (#557) --- src/enkf/controlvec.f90 | 11 +- src/enkf/gridinfo_gfs.f90 | 2 +- src/enkf/gridio_gfs.f90 | 485 ++++++- src/enkf/params.f90 | 29 +- src/enkf/readconvobs.f90 | 5 +- src/enkf/statevec.f90 | 4 +- src/gsi/general_read_gfsatm.f90 | 2362 +++++++++++++++++-------------- src/gsi/gsimod.F90 | 4 +- src/gsi/jfunc.f90 | 5 + src/gsi/netcdfgfs_io.f90 | 33 +- src/gsi/read_prepbufr.f90 | 33 +- src/gsi/setupq.f90 | 163 ++- src/gsi/setupt.f90 | 143 +- src/gsi/update_guess.f90 | 6 +- 14 files changed, 2170 insertions(+), 1115 deletions(-) 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/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_gfs.f90 b/src/enkf/gridio_gfs.f90 index 456f8126e2..5d560be3a8 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)) @@ -554,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 @@ -562,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 @@ -662,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) @@ -731,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) @@ -1100,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 @@ -1998,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. @@ -3402,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,& @@ -3438,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 @@ -3450,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 @@ -3774,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 @@ -4402,6 +4817,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/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 f3b1e38f04..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 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/general_read_gfsatm.f90 b/src/gsi/general_read_gfsatm.f90 index 0216b95fb6..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,64 +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 - 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) + 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)) @@ -2853,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 @@ -2862,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. @@ -2884,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 @@ -3351,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) @@ -3375,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) @@ -3382,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 @@ -3396,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 @@ -3429,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/gsimod.F90 b/src/gsi/gsimod.F90 index ed4bbb1e55..cf885c2b64 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -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 @@ -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 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/netcdfgfs_io.f90 b/src/gsi/netcdfgfs_io.f90 index e1255b773c..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) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index f992ace329..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 @@ -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) 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/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/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) From 8735959064c3661a85b16328cb0bfc0cd546bc09 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Tue, 6 Jun 2023 14:59:42 -0400 Subject: [PATCH 15/17] update fix submodule to bring in gfs.v16.3.7 changes (#581) --- fix | 2 +- modulefiles/gsi_hera.gnu.lua | 2 +- modulefiles/gsi_hera.intel.lua | 2 +- modulefiles/gsi_jet.lua | 2 +- modulefiles/gsi_orion.lua | 2 +- modulefiles/gsi_s4.lua | 2 +- modulefiles/gsi_wcoss2.lua | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) 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_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 1efb6f4405..62a915ef72 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 855597a08e..a769deca6f 100644 --- a/modulefiles/gsi_jet.lua +++ b/modulefiles/gsi_jet.lua @@ -27,6 +27,6 @@ pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2") pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2") -pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/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 b69467f7ce..fb3df720e4 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 209af8c8a9..1872f89d17 100644 --- a/modulefiles/gsi_wcoss2.lua +++ b/modulefiles/gsi_wcoss2.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) load("gsi_common") -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") From 00cac5443e49f466a8d117b18a7c30903747b6a0 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA Date: Tue, 27 Jun 2023 00:15:18 -0400 Subject: [PATCH 16/17] Feature/enkf q2 (#568) Resubmit PR for cleaning the unneeded item in the previous PR In correspondence to the EMC GSI Issue#566, this PR contains a quick adding of the clipping of negative values of sphum (q) in the analysis of FV3-LAM EnKF. This part of codes are not tested in the current GSI regression tests, which, hence, are not run. The current codes are verified using local FV3-LAM case. It is found the differences from this changes exist for sphum ( maximum values about 0.003 (units) and 0.3 K for T (sensible T). The latter is because the sphum would be used when the analysis TV is converted to T. All differences are on spontaneous points and values are reasonable as expected. Hence, the code is regarded as verified. Fixes #566 **DUE DATE for this PR is 6/15/2023.** If this PR is not merged into `develop` by this date, the PR will be closed and returned to the developer. --- src/enkf/gridio_fv3reg.f90 | 72 +++++++++++--------------------------- src/enkf/innovstats.f90 | 2 +- 2 files changed, 22 insertions(+), 52 deletions(-) diff --git a/src/enkf/gridio_fv3reg.f90 b/src/enkf/gridio_fv3reg.f90 index 4939dd16ee..068e6cba8b 100644 --- a/src/enkf/gridio_fv3reg.f90 +++ b/src/enkf/gridio_fv3reg.f90 @@ -42,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 @@ -694,7 +694,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid ps_ind = getindex(vars2d, 'ps') ! Ps (2D) - + clip=tiny(clip) !---------------------------------------------------------------------- if (nbackgrounds > 1) then write(6,*)'gridio/writegriddata: writing multiple backgrounds not yet supported' @@ -853,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 @@ -866,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' @@ -932,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 @@ -955,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 @@ -978,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 @@ -1001,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 @@ -1024,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 @@ -1046,10 +1035,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 @@ -1888,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 @@ -2173,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 @@ -2186,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 @@ -2281,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,& @@ -2315,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,& @@ -2349,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,& @@ -2383,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,& @@ -2417,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,& @@ -2450,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,& 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,& From 333ae16183c1c9a9b51c789efcf67888167ab61b Mon Sep 17 00:00:00 2001 From: emilyhcliu <36091766+emilyhcliu@users.noreply.github.com> Date: Wed, 28 Jun 2023 09:37:21 -0400 Subject: [PATCH 17/17] Zero increments for precipitation hydrometeors are written as missing values instead of zeros (#578) --- src/enkf/gridio_gfs.f90 | 283 ++++++++++++++++++---------------------- 1 file changed, 130 insertions(+), 153 deletions(-) diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index 5d560be3a8..e4631f4e2d 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -4270,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 @@ -4393,9 +4394,6 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! old logical massbal_adjust, if non-zero use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. & qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 ) - ! Currently, we do not let precipiation to affect the enkf analysis - ! The following line will be removed after testing - use_full_hydro = .false. dsfg = open_dataset(filenamein, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) call read_attribute(dsfg, 'ak', values_1d,errcode=iret) @@ -4621,141 +4619,31 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! Read in background + increment and make sure the minimum is qcmin ! Adjust increment accordingly - if (use_full_hydro) then - ! liq wat increment - 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 - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - inc(:) = zero - if (ql_ind > 0) then - call copyfromgrdin(grdin(:,levels(ql_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 clwmr 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)) - - ! icmr increment - call read_vardata(dsfg, 'icmr', q, 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 - inc(:) = zero - if (qi_ind > 0) then - call copyfromgrdin(grdin(:,levels(qi_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 icmr increment - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('icmr_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - - ! 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)) - else - ! liq wat increment - ! icmr increment - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - ug = zero - if (cw_ind > 0) then - call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) - end if + ! 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; 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 + ! 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 @@ -4764,29 +4652,118 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate enddo vg = ug * work ! cloud ice ug = ug * (one - work) ! cloud water - inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) endif - inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) - enddo - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) - end do - if (should_zero_increments_for('icmr_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) + else if (qi_ind > 0) then + call copyfromgrdin(grdin(:,levels(qi_ind-1)+krev,nb,ne),vg) + endif + 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 + if (should_zero_increments_for('icmr_inc')) inc3dout = zero + 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)