From 8ed034fe6f2a1aac5ce145b4a1b441e3aa37d8ca Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Fri, 26 Jan 2024 11:47:41 -0500 Subject: [PATCH] Complete issue #607 (Optimization of multiscale regional runs) (#670) --- src/enkf/controlvec.f90 | 2 +- src/enkf/letkf.f90 | 19 +- src/gsi/adjtest.f90 | 2 +- src/gsi/apply_scaledepwgts.f90 | 1 - src/gsi/balmod.f90 | 14 +- src/gsi/berror.f90 | 3 +- src/gsi/calctends.f90 | 3 +- src/gsi/calctends_ad.f90 | 3 +- src/gsi/calctends_no_ad.f90 | 3 +- src/gsi/calctends_no_tl.f90 | 5 +- src/gsi/calctends_tl.f90 | 3 +- src/gsi/control2state.f90 | 129 +- src/gsi/control_vectors.f90 | 9 +- src/gsi/convthin.f90 | 458 +++--- src/gsi/convthin_time.f90 | 455 +++--- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 2 +- src/gsi/deter_sfc_mod.f90 | 8 +- src/gsi/ensctl2model.f90 | 4 +- src/gsi/ensctl2model_ad.f90 | 2 +- src/gsi/ensctl2state.f90 | 450 ++++-- src/gsi/ensctl2state_ad.f90 | 287 ---- src/gsi/general_commvars_mod.f90 | 7 +- src/gsi/get_gefs_ensperts_dualres.f90 | 3 +- src/gsi/gsdcloudanalysis.F90 | 2 +- src/gsi/gsi_files.cmake | 1 - src/gsi/gsi_rfv3io_mod.f90 | 140 +- src/gsi/gsisub.F90 | 2 +- src/gsi/hdraobmod.f90 | 15 +- src/gsi/hybrid_ensemble_isotropic.F90 | 26 +- src/gsi/hybrid_ensemble_parameters.f90 | 1 + src/gsi/intjcmod.f90 | 16 +- src/gsi/intrw.f90 | 18 +- src/gsi/jgrad.f90 | 1 + src/gsi/m_extOzone.F90 | 2 +- src/gsi/mod_fv3_lola.f90 | 9 +- src/gsi/obs_para.f90 | 6 +- src/gsi/obs_sensitivity.f90 | 1 + src/gsi/observer.F90 | 2 - src/gsi/obsmod.F90 | 14 +- src/gsi/pcgsoi.f90 | 13 +- src/gsi/prewgt_reg.f90 | 9 +- src/gsi/read_NASA_LaRC_cloud.f90 | 7 + src/gsi/read_aerosol.f90 | 5 +- src/gsi/read_avhrr.f90 | 1 + src/gsi/read_dbz_nc.f90 | 119 +- src/gsi/read_dbz_netcdf.f90 | 32 +- src/gsi/read_fed.f90 | 7 +- src/gsi/read_fl_hdob.f90 | 160 ++- src/gsi/read_gfs_ozone_for_regional.f90 | 12 +- src/gsi/read_goesglm.f90 | 73 +- src/gsi/read_goesimgr_skycover.f90 | 440 +++--- src/gsi/read_l2bufr_mod.f90 | 14 +- src/gsi/read_mitm_mxtm.f90 | 12 +- src/gsi/read_nsstbufr.f90 | 1 + src/gsi/read_obs.F90 | 4 +- src/gsi/read_prepbufr.f90 | 467 ++++--- src/gsi/read_radar.f90 | 392 ++++-- src/gsi/read_radar_wind_ascii.f90 | 546 ++++---- src/gsi/read_rapidscat.f90 | 140 +- src/gsi/read_satmar.f90 | 139 +- src/gsi/read_satwnd.f90 | 1452 ++++++++++---------- src/gsi/read_sfcwnd.f90 | 139 +- src/gsi/read_viirs.f90 | 3 +- src/gsi/read_wcpbufr.f90 | 204 +-- src/gsi/setupbend.f90 | 2 +- src/gsi/setupcldch.f90 | 2 +- src/gsi/setupdbz.f90 | 2 +- src/gsi/setupfed.f90 | 4 +- src/gsi/setupgust.f90 | 2 +- src/gsi/setuphowv.f90 | 2 +- src/gsi/setuplcbas.f90 | 2 +- src/gsi/setuplight.f90 | 2 +- src/gsi/setuplwcp.f90 | 2 +- src/gsi/setupmitm.f90 | 2 +- src/gsi/setupmxtm.f90 | 2 +- src/gsi/setupoz.f90 | 2 - src/gsi/setuppblh.f90 | 2 +- src/gsi/setuppmsl.f90 | 2 +- src/gsi/setupps.f90 | 2 +- src/gsi/setuppw.f90 | 2 +- src/gsi/setupq.f90 | 2 +- src/gsi/setuprad.f90 | 10 +- src/gsi/setuprw.f90 | 12 +- src/gsi/setupspd.f90 | 2 +- src/gsi/setupswcp.f90 | 2 +- src/gsi/setupt.f90 | 3 +- src/gsi/setuptcamt.f90 | 2 +- src/gsi/setuptd2m.f90 | 2 +- src/gsi/setupuwnd10m.f90 | 2 +- src/gsi/setupvis.f90 | 2 +- src/gsi/setupvwnd10m.f90 | 2 +- src/gsi/setupw.f90 | 201 ++- src/gsi/setupwspd10m.f90 | 2 +- src/gsi/state_vectors.f90 | 6 +- src/gsi/statsconv.f90 | 2 +- src/gsi/stpcalc.f90 | 329 +++-- src/gsi/stpfed.f90 | 2 - src/gsi/stprw.f90 | 14 +- src/gsi/turbl.f90 | 3 - src/gsi/turbl_ad.f90 | 3 - src/gsi/turbl_tl.f90 | 2 - src/gsi/windht.f90 | 30 +- src/gsi/write_incr.f90 | 1 + 103 files changed, 3689 insertions(+), 3500 deletions(-) delete mode 100644 src/gsi/ensctl2state_ad.f90 diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90 index 40dff4dbad..808eae2e28 100644 --- a/src/enkf/controlvec.f90 +++ b/src/enkf/controlvec.f90 @@ -191,7 +191,7 @@ subroutine read_control() ! read ensemble members on IO tasks implicit none real(r_double) :: t1,t2 -integer(i_kind) :: nb,nlev,ne +integer(i_kind) :: nb,ne integer(i_kind) :: q_ind integer(i_kind) :: ierr diff --git a/src/enkf/letkf.f90 b/src/enkf/letkf.f90 index 9b74cecd75..dcd68be8ff 100644 --- a/src/enkf/letkf.f90 +++ b/src/enkf/letkf.f90 @@ -172,8 +172,8 @@ subroutine letkf_update() if (nproc == 0) print *,'using',nthreads,' openmp threads' ! define a few frequently used parameters -r_nanals=one/float(nanals) -r_nanalsm1=one/float(nanals-1) +r_nanals=one/real(nanals,r_kind) +r_nanalsm1=one/real(nanals-1,r_kind) mincorrlength_factsq = mincorrlength_fact**2 kdobs=associated(kdtree_obs2) @@ -541,31 +541,34 @@ subroutine letkf_update() enddo !$omp end parallel do +tmean=zero +tmin=zero +tmax=zero tend = mpi_wtime() call mpi_reduce(tend-tbegin,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) -tmean = tmean/numproc +tmean = tmean/real(numproc,r_kind) call mpi_reduce(tend-tbegin,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) call mpi_reduce(tend-tbegin,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) if (nproc .eq. 0) print *,'min/max/mean time to do letkf update ',tmin,tmax,tmean t2 = t2/nthreads; t3 = t3/nthreads; t4 = t4/nthreads; t5 = t5/nthreads if (nproc == 0) print *,'time to process analysis on gridpoint = ',t2,t3,t4,t5,' secs on task',nproc call mpi_reduce(t2,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) -tmean = tmean/numproc +tmean = tmean/real(numproc,r_kind) call mpi_reduce(t2,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) call mpi_reduce(t2,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) if (nproc .eq. 0) print *,',min/max/mean t2 = ',tmin,tmax,tmean call mpi_reduce(t3,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) -tmean = tmean/numproc +tmean = tmean/real(numproc,r_kind) call mpi_reduce(t3,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) call mpi_reduce(t3,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) if (nproc .eq. 0) print *,',min/max/mean t3 = ',tmin,tmax,tmean call mpi_reduce(t4,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) -tmean = tmean/numproc +tmean = tmean/real(numproc,r_kind) call mpi_reduce(t4,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) call mpi_reduce(t4,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) if (nproc .eq. 0) print *,',min/max/mean t4 = ',tmin,tmax,tmean call mpi_reduce(t5,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) -tmean = tmean/numproc +tmean = tmean/real(numproc,r_kind) call mpi_reduce(t5,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) call mpi_reduce(t5,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) if (nproc .eq. 0) print *,',min/max/mean t5 = ',tmin,tmax,tmean @@ -590,7 +593,7 @@ subroutine letkf_update() call mpi_reduce(nobslocal_max,nobslocal_maxall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr) call mpi_reduce(nobslocal_min,nobslocal_minall,1,mpi_integer,mpi_min,0,mpi_comm_world,ierr) call mpi_reduce(nobslocal_mean,nobslocal_meanall,1,mpi_integer,mpi_sum,0,mpi_comm_world,ierr) - if (nproc == 0) print *,'min/max/mean number of obs in local volume',nobslocal_minall,nobslocal_maxall,nint(nobslocal_meanall/float(numproc)) + if (nproc == 0) print *,'min/max/mean number of obs in local volume',nobslocal_minall,nobslocal_maxall,nint(nobslocal_meanall/real(numproc,r_kind)) endif call mpi_reduce(nobslocal_max,nobslocal_maxall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr) call mpi_reduce(nobslocal_min,nobslocal_minall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr) diff --git a/src/gsi/adjtest.f90 b/src/gsi/adjtest.f90 index e1a5da7d07..3447dec202 100644 --- a/src/gsi/adjtest.f90 +++ b/src/gsi/adjtest.f90 @@ -38,7 +38,7 @@ module adjtest use gsi_bundlemod, only: assignment(=) use bias_predictors, only: predictors,allocate_preds,deallocate_preds, & assignment(=) -use control2state_mod, only: control2state,c2sset,control2state_ad +use control2state_mod, only: control2state,control2state_ad implicit none private diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90 index e4952b28fa..585711c90b 100644 --- a/src/gsi/apply_scaledepwgts.f90 +++ b/src/gsi/apply_scaledepwgts.f90 @@ -151,7 +151,6 @@ subroutine apply_scaledepwgts(m,grd_in,sp_in) use general_specmod, only: spec_vars use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: spc_multwgt,en_perts,nsclgrp,n_ens - use mpimod, only: mype implicit none ! Declare passed variables diff --git a/src/gsi/balmod.f90 b/src/gsi/balmod.f90 index 1408530a3f..96181864a1 100644 --- a/src/gsi/balmod.f90 +++ b/src/gsi/balmod.f90 @@ -689,13 +689,7 @@ subroutine balance(t,p,st,vp,fpsproj,fut2ps) !! Strong balance constraint !! Pass uvflag=.false. - if(lsqrtb) then - call strong_bk(st,vp,p,t,.false.) - else - if(tlnmc_option==1 .or. tlnmc_option==4) call strong_bk(st,vp,p,t,.false.) - endif - - + if(lsqrtb .or. tlnmc_option==1 .or. tlnmc_option==4) call strong_bk(st,vp,p,t,.false.) return end subroutine balance @@ -777,11 +771,7 @@ subroutine tbalance(t,p,st,vp,fpsproj,fut2ps) ! Adjoint of strong balance constraint ! pass uvflag=.false. - if(lsqrtb) then - call strong_bk_ad(st,vp,p,t,.false.) - else - if(tlnmc_option==1 .or. tlnmc_option==4) call strong_bk_ad(st,vp,p,t,.false.) - endif + if(lsqrtb .or. tlnmc_option==1 .or. tlnmc_option==4) call strong_bk_ad(st,vp,p,t,.false.) ! REGIONAL BRANCH if (regional) then diff --git a/src/gsi/berror.f90 b/src/gsi/berror.f90 index 029caffa19..ec5f5eee8d 100644 --- a/src/gsi/berror.f90 +++ b/src/gsi/berror.f90 @@ -844,8 +844,7 @@ subroutine create_berror_vars_reg ! Grid constant for background error - allocate(be(ndeg), & - qvar3d(lat2,lon2,nsig)) + allocate(be(ndeg),qvar3d(lat2,lon2,nsig)) if(nc3d>0)then allocate(alv(llmin:llmax,ndeg,nsig,nc3d), & dssv(lat2,lon2,nsig,nc3d)) diff --git a/src/gsi/calctends.f90 b/src/gsi/calctends.f90 index 4bd2c64e24..c6c58e9f4c 100644 --- a/src/gsi/calctends.f90 +++ b/src/gsi/calctends.f90 @@ -62,6 +62,7 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) use gsi_bundlemod, only: gsi_bundlegetpointer use mpeu_util, only: die + use turblmod, only: use_pbl implicit none ! Declare passed variables @@ -357,7 +358,7 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) end do end do !end do k - call turbl(u,v,pri,t,teta,z,u_t,v_t,t_t,jtstart(kk),jtstop(kk)) + if(use_pbl)call turbl(u,v,pri,t,teta,z,u_t,v_t,t_t,jtstart(kk),jtstop(kk)) if(.not.wrf_nmm_regional.and..not.nems_nmmb_regional)then do k=1,nsig diff --git a/src/gsi/calctends_ad.f90 b/src/gsi/calctends_ad.f90 index 72b5b76ffa..4f85a74485 100644 --- a/src/gsi/calctends_ad.f90 +++ b/src/gsi/calctends_ad.f90 @@ -67,6 +67,7 @@ subroutine calctends_ad(fields,fields_dt,mype) use mpeu_util, only: die use derivsmod, only: gsi_xderivative_bundle use derivsmod, only: gsi_yderivative_bundle + use turblmod, only: use_pbl implicit none ! Declare passed variables @@ -356,7 +357,7 @@ subroutine calctends_ad(fields,fields_dt,mype) end do end if - call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),& + if(use_pbl)call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),& u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk)) do k=nsig,1,-1 diff --git a/src/gsi/calctends_no_ad.f90 b/src/gsi/calctends_no_ad.f90 index e50f96df72..af792b69a5 100644 --- a/src/gsi/calctends_no_ad.f90 +++ b/src/gsi/calctends_no_ad.f90 @@ -72,6 +72,7 @@ subroutine calctends_no_ad(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) use gsi_bundlemod, only: gsi_bundlegetpointer use derivsmod, only: gsi_xderivative_bundle use derivsmod, only: gsi_yderivative_bundle + use turblmod, only: use_pbl implicit none ! Declare passed variables @@ -210,7 +211,7 @@ subroutine calctends_no_ad(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) end do end if - call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),& + if(use_pbl)call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),& u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk)) do k=nsig,1,-1 diff --git a/src/gsi/calctends_no_tl.f90 b/src/gsi/calctends_no_tl.f90 index d4dacb94a5..c66a2abcc6 100644 --- a/src/gsi/calctends_no_tl.f90 +++ b/src/gsi/calctends_no_tl.f90 @@ -37,7 +37,7 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) ! v - meridional wind on subdomain ! t - virtual temperature on subdomain ! mype - task id -! uvflag - logical, set to true for st,vp wind components, instead of stream/potential function +! uvflag - logical, set to true for u,v wind components, instead of stream/potential function ! ! output argument list: ! u_t - time tendency of u @@ -64,6 +64,7 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) use gsi_bundlemod, only: gsi_bundlegetpointer use derivsmod, only: gsi_xderivative_bundle use derivsmod, only: gsi_yderivative_bundle + use turblmod, only: use_pbl implicit none ! Declare passed variables @@ -364,7 +365,7 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) end do !end do j end do !end do k - call turbl_tl(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),& + if(use_pbl)call turbl_tl(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),& u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk)) if(.not.wrf_nmm_regional.and..not.nems_nmmb_regional)then diff --git a/src/gsi/calctends_tl.f90 b/src/gsi/calctends_tl.f90 index 59507fc6db..f5202f5f34 100644 --- a/src/gsi/calctends_tl.f90 +++ b/src/gsi/calctends_tl.f90 @@ -69,6 +69,7 @@ subroutine calctends_tl(fields,fields_dt,mype) use mpeu_util, only: die, getindex use derivsmod, only: gsi_xderivative_bundle use derivsmod, only: gsi_yderivative_bundle + use turblmod, only: use_pbl implicit none ! Declare passed variables @@ -474,7 +475,7 @@ subroutine calctends_tl(fields,fields_dt,mype) end do !end do j end do !end do k - call turbl_tl(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),& + if(use_pbl)call turbl_tl(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),& u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk)) if(.not.wrf_nmm_regional.and..not.nems_nmmb_regional)then diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90 index f2d8849ce0..9dd4bca7b3 100644 --- a/src/gsi/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -39,15 +39,8 @@ module control2state_mod 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 @@ -221,23 +214,6 @@ subroutine control2state(xhat,sval,bval) end if end if - if(jj == 1)then -! Biases - do ii=1,nsclen - bval%predr(ii)=xhat%predr(ii) - enddo - - do ii=1,npclen - bval%predp(ii)=xhat%predp(ii) - enddo - - if (ntclen>0) then - do ii=1,ntclen - bval%predt(ii)=xhat%predt(ii) - enddo - end if - end if - !$omp section ! Get pointers to required state variables call gsi_bundlegetpointer (sval(jj),'prse',sv_prse,istatus) @@ -286,14 +262,57 @@ subroutine control2state(xhat,sval,bval) call gsi_bundlegetvar ( wbundle, 'ps' , sv_ps, istatus ) !$omp section - call gsi_bundlegetpointer (sval(jj),'sst' ,sv_sst, istatus) - call gsi_bundlegetvar ( wbundle, 'sst', sv_sst, istatus ) call gsi_bundlegetpointer (sval(jj),'oz' ,sv_oz , istatus_oz) if (icoz>0) then call gsi_bundlegetvar ( wbundle, 'oz' , sv_oz, istatus ) else if(istatus_oz==0) sv_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_tl(sval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3) + else + do ic=1,ngases + ! take care gases and aero variables if one to one mapping + id=getindex(cvars3d,gases(ic)) + if (id>0) then + call gsi_bundlegetpointer (sval(jj),gases(ic),sv_rank3,istatus) + call gsi_bundlegetvar (wbundle, gases(ic),sv_rank3,istatus) + endif + id=getindex(cvars2d,gases(ic)) + if (id>0) then + call gsi_bundlegetpointer (sval(jj),gases(ic),sv_rank2,istatus) + call gsi_bundlegetvar (wbundle, gases(ic),sv_rank2,istatus) + endif + enddo + end if + +!$omp section + if(jj == 1)then +! Biases + do ii=1,nsclen + bval%predr(ii)=xhat%predr(ii) + enddo + + do ii=1,npclen + bval%predp(ii)=xhat%predp(ii) + enddo + + if (ntclen>0) then + do ii=1,ntclen + bval%predt(ii)=xhat%predt(ii) + enddo + end if + end if + + call gsi_bundlegetpointer (sval(jj),'sst' ,sv_sst, istatus) + call gsi_bundlegetvar ( wbundle, 'sst', sv_sst, istatus ) + if (icgust>0) then call gsi_bundlegetpointer (sval(jj),'gust' ,sv_gust, istatus) call gsi_bundlegetvar ( wbundle, 'gust', sv_gust, istatus ) @@ -361,28 +380,6 @@ subroutine control2state(xhat,sval,bval) call gsi_bundlegetvar ( wbundle, 'vwnd10m', sv_vwnd10m, istatus ) 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_tl(sval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3) - else - do ic=1,ngases - ! take care gases and aero variables if one to one mapping - id=getindex(cvars3d,gases(ic)) - if (id>0) then - call gsi_bundlegetpointer (sval(jj),gases(ic),sv_rank3,istatus) - call gsi_bundlegetvar (wbundle, gases(ic),sv_rank3,istatus) - endif - id=getindex(cvars2d,gases(ic)) - if (id>0) then - call gsi_bundlegetpointer (sval(jj),gases(ic),sv_rank2,istatus) - call gsi_bundlegetvar (wbundle, gases(ic),sv_rank2,istatus) - endif - enddo - end if !$omp end parallel sections @@ -513,7 +510,7 @@ subroutine c2sset(xhat,sval) call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus) call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus) -c2sset_flg=.false. +c2sset_flg=.false. ! set to true in setup. set to false after first (only) call to c2sset return end subroutine c2sset subroutine control2state_ad(rval,bval,grad) @@ -678,20 +675,6 @@ subroutine control2state_ad(rval,bval,grad) 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 @@ -743,8 +726,6 @@ subroutine control2state_ad(rval,bval,grad) !$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) @@ -778,6 +759,24 @@ subroutine control2state_ad(rval,bval,grad) endif enddo end if +!$omp section + 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 + + call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus) + call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus ) + if (icgust>0) then call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus) call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus ) diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90 index 73f605b95f..af376995bd 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -113,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,c2sset_flg + final_anacv,c2sset_flg,e2sset_flg ! ! Public variables @@ -158,7 +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 +logical :: c2sset_flg,e2sset_flg integer(i_kind) :: m_vec_alloc, max_vec_alloc, m_allocs, m_deallocs @@ -415,7 +415,8 @@ subroutine init_anacv write(6,*) myname_,': ALL CONTROL VARIABLES ', nrf_var end if lcalc_gfdl_cfrac = .false. -c2sset_flg = .true. +c2sset_flg = .true. ! set to true in setup. set to false after first (only) call to c2sset +e2sset_flg = .true. ! set to true in setup. set to false after first (only) call to ensctl2state_set end subroutine init_anacv subroutine final_anacv @@ -1229,7 +1230,7 @@ subroutine prt_norms(xcv,sgrep) zt=sqrt(zt) if (mype==0) then - write(6,*)sgrep,' global norm =',real(zt,r_kind) + write(6,*)sgrep,' global norm =',zt endif !_RT call prt_norms_vars(xcv,sgrep) --->> this routine is hanging diff --git a/src/gsi/convthin.f90 b/src/gsi/convthin.f90 index 3a52188d73..edac1adbcf 100644 --- a/src/gsi/convthin.f90 +++ b/src/gsi/convthin.f90 @@ -12,7 +12,6 @@ module convthin ! ! subroutines included: ! make3grids -! map3grids ! map3grids_m ! keep thinned data ! del3grids ! @@ -31,23 +30,24 @@ module convthin private ! set subroutines to public public :: make3grids - public :: map3grids public :: map3grids_m public :: del3grids ! set passed variables to public public :: use_all - integer(i_kind):: mlat + integer(i_kind):: mlat,itxmax,nlevp integer(i_kind),allocatable,dimension(:):: mlon - integer(i_kind),allocatable,dimension(:,:):: icount,icount_fore,icount_aft,ibest_obs,ibest_save + logical ,allocatable,dimension(:,:):: icount,icount_fore,icount_aft + integer(i_kind),allocatable,dimension(:,:):: ibest_obs,ibest_obs_aft,ibest_obs_fore real(r_kind),allocatable,dimension(:):: glat real(r_kind),allocatable,dimension(:,:):: glon,hll,score_crit,score_crit_fore,score_crit_aft logical use_all + logical setfore, setaft, setnormal contains - subroutine make3grids(rmesh,nlevp) + subroutine make3grids(rmesh,nlevpp) !$$$ subprogram documentation block ! . . . . ! subprogram: make3grids @@ -69,7 +69,7 @@ subroutine make3grids(rmesh,nlevp) ! rmesh - mesh size (km) of thinning grid. If (rmesh <= one), ! then no thinning of the data will occur. Instead, ! all data will be used without thinning. -! nlevp - vertical levels +! nlevpp - vertical levels ! ! attributes: ! language: f90 @@ -82,12 +82,12 @@ subroutine make3grids(rmesh,nlevp) implicit none real(r_kind) ,intent(in ) :: rmesh - integer(i_kind),intent(in ) :: nlevp + integer(i_kind),intent(in ) :: nlevpp real(r_kind),parameter:: r360 = 360.0_r_kind integer(i_kind) i,j - integer(i_kind) mlonx,mlonj,itxmax + integer(i_kind) mlonx,mlonj real(r_kind) dgv,halfpi,dx,dy real(r_kind) twopi @@ -95,6 +95,7 @@ subroutine make3grids(rmesh,nlevp) real(r_kind) rkm2dg,glatm real(r_quad) delat + nlevp=nlevpp ! If there is to be no thinning, simply return to calling routine use_all=.false. if(abs(rmesh) <= one)then @@ -132,7 +133,7 @@ subroutine make3grids(rmesh,nlevp) factor = abs(cos(abs(glatm))) if (rmesh>zero) then - mlonj = nint(mlonx*factor) + mlonj = nint(mlonx*factor) mlon(j) = max(2,mlonj) delon = dlon_grid/mlon(j) else @@ -155,247 +156,108 @@ subroutine make3grids(rmesh,nlevp) enddo end do + setnormal=.false. + setfore=.false. + setaft=.false. -! Allocate and initialize arrays + return + end subroutine make3grids + subroutine createnormal +!$$$ subprogram documentation block +! . . . . +! subprogram: createnormal +! prgmmr: derber org: np23 date: 2023-10-20 +! +! abstract: This routine creates and initializes arrays for normal thinning +! +! program history log: +! 2023-10-20 derber +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + integer i,j allocate(icount(itxmax,nlevp)) - allocate(icount_fore(itxmax,nlevp)) - allocate(icount_aft(itxmax,nlevp)) allocate(ibest_obs(itxmax,nlevp)) - allocate(ibest_save(itxmax,nlevp)) allocate(score_crit(itxmax,nlevp)) - allocate(score_crit_fore(itxmax,nlevp)) - allocate(score_crit_aft(itxmax,nlevp)) do j=1,nlevp do i=1,itxmax - icount(i,j) = 0 - icount_fore(i,j) = 0 - icount_aft(i,j) = 0 + icount(i,j) = .false. ibest_obs(i,j)= 0 - ibest_save(i,j)= 0 score_crit(i,j)= 9.99e6_r_kind - score_crit_fore(i,j) = 9.99e6_r_kind - score_crit_aft(i,j) = 9.99e6_r_kind end do end do - + setnormal=.true. return - end subroutine make3grids - - subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs,& - iobsout,iin,iiout,iuse,foreswp,aftswp) - + end subroutine createnormal + subroutine createfore !$$$ subprogram documentation block ! . . . . -! subprogram: map3grids -! prgmmr: treadon org: np23 date: 2002-10-17 +! subprogram: createfore +! prgmmr: derber org: np23 date: 2023-10-20 ! -! abstract: This routine maps convential observations to a 3d thinning grid. +! abstract: This routine creates and initializes arrays for fore thinning ! ! program history log: -! 2002-10-17 treadon -! 2004-06-22 treadon - update documentation -! 2004-07-23 derber - modify code to thin obs as read in -! 2004-12-08 li, xu - fix bug --> set iuse=.true. when use_all=.true. -! 2005-10-14 treadon - variable name change (dlat0,dlon0) --> d*_earth -! 2006-01-25 kistler - extend 2d to 3d -! 2008-06-04 safford - rm unused vars -! 2010-08-23 tong - add flg as an input argument of map3grids, so that the order of values -! of the vertical cooridnate can either increase or decrease -! 2012-05-25 li, wang - add TDR fore/aft sweep separation for thinning,xuguang.wang@ou.edu -! 2013-01-23 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) +! 2023-10-20 derber ! -! input argument list: -! flg - marks order of values in vertical dirction (1=increasing, -1=decreasing) -! pflag - type of pressure-type levels; 0 : sigma level, 1 : determined by convinfo file -! pcoord - veritical coordinate values -! nlevp - number of vertical levels -! dlat_earth - earth relative observation latitude (radians) -! dlon_earth - earth relative observation longitude (radians) -! pob - observation pressure ob -! crit1 - quality indicator for observation (smaller = better) -! iin - counter of input data -! foreswp - if true, TDR scan is fore -! aftswp - if true, TDR scan is aft +! attributes: +! language: f90 +! machine: ibm rs/6000 sp ! -! output argument list: -! iobs - observation counter -! iobsout- location for observation to be put -! iuse - .true. if observation should be used -! iiout - counter of data replaced -! +!$$$ + integer i,j + allocate(icount_fore(itxmax,nlevp)) + allocate(ibest_obs_fore(itxmax,nlevp)) + allocate(score_crit_fore(itxmax,nlevp)) + + do j=1,nlevp + do i=1,itxmax + icount_fore(i,j) = .false. + ibest_obs_fore(i,j)= 0 + score_crit_fore(i,j)= 9.99e6_r_kind + end do + end do + setfore=.true. + return + end subroutine createfore + subroutine createaft +!$$$ subprogram documentation block +! . . . . +! subprogram: createaft +! prgmmr: derber org: np23 date: 2023-10-20 +! +! abstract: This routine creates and initializes arrays for aft thinning +! +! program history log: +! 2023-10-20 derber ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ - use constants, only: one, half,two,three - implicit none - - logical ,intent( out) :: iuse - integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,iin - integer(i_kind) ,intent(inout) :: iobs - integer(i_kind) ,intent( out) :: iobsout,iiout - real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob - real(r_kind),dimension(nlevp),intent(in ) :: pcoord - - integer(i_kind):: ip,itx - integer(i_kind) ix,iy - - real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp - real(r_kind) crit!,dist1 - - logical foreswp, aftswp - - iiout = 0 - -! If using all data (no thinning), simply return to calling routine - if(use_all)then - iuse=.true. - iobs=iobs+1 - iobsout=iobs - return - end if - -! Compute (i,j,k) indices of coarse mesh grid (grid number 1) which -! contains the current observation. - dlat1=dlat_earth - dlon1=dlon_earth - pob1=pob - - call grdcrd1(pob1,pcoord,nlevp,flg) - ip=int(pob1) - dp=pob1-ip - ip=max(1,min(ip,nlevp)) - - call grdcrd1(dlat1,glat,mlat,1) - iy=int(dlat1) - dy=dlat1-iy - iy=max(1,min(iy,mlat)) - - call grdcrd1(dlon1,glon(1,iy),mlon(iy),1) - ix=int(dlon1) - 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 - - itx=hll(ix,iy) - -! Compute distance metric (smaller is closer to center of cube) -! dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half - - -! Examine various cases regarding what to do with current obs. -! Start by assuming observation will be selected. - iuse=.true. - -! Determine "score" for observation. Lower score is better. -! crit = crit1*dist1 - crit = crit1 - - -! TDR fore (Pseudo-dual-Doppler-radars) - - if(foreswp) then ! fore sweeps - -! Case(1): first obs at this location, keep this obs as starting point - 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 - ibest_save(itx,ip) = iin - -! 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 - score_crit_fore(itx,ip)= crit - icount_fore(itx,ip)=icount_fore(itx,ip)+1 - iobsout=ibest_obs(itx,ip) - iiout = ibest_save(itx,ip) - ibest_save(itx,ip)=iin - -! Case(3): obs score > best value at this location, -! 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 - -! TDR aft (Pseudo-dual-Doppler-radars) - else if(aftswp) then ! aft sweeps - -! Case(1): first obs at this location, keep this obs as starting point - if (icount_aft(itx,ip)==0) then - 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 - ibest_save(itx,ip) = iin - - -! 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 - score_crit_aft(itx,ip)= crit - icount_aft(itx,ip)=icount_aft(itx,ip)+1 - iobsout=ibest_obs(itx,ip) - iiout = ibest_save(itx,ip) - ibest_save(itx,ip)=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. - else - iuse = .false. - endif ! cases - - else - -! Case: obs score < best value at this location, -! --> update score, count, and best obs counters - 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 - iiout = ibest_save(itx,ip) - ibest_save(itx,ip)=iin - -! Case: first obs at this location, -! --> keep this obs as starting point - elseif (icount(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs - score_crit(itx,ip)= crit - ibest_obs(itx,ip) = iobs - icount(itx,ip)=icount(itx,ip)+1 - ibest_save(itx,ip) = iin - -! Case: none of the above cases are satisified, -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - else - iuse = .false. - end if - end if - return - + integer i,j + allocate(icount_aft(itxmax,nlevp)) + allocate(ibest_obs_aft(itxmax,nlevp)) + allocate(score_crit_aft(itxmax,nlevp)) - end subroutine map3grids + do j=1,nlevp + do i=1,itxmax + icount_aft(i,j) = .false. + ibest_obs_aft(i,j)= 0 + score_crit_aft(i,j)= 9.99e6_r_kind + end do + end do + setaft=.true. + return + end subroutine createaft - subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs,& - iobsout,iin,iiout,iuse,maxobs,usage,rusage,foreswp,aftswp) + subroutine map3grids_m(flg,save_all,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs,& + iuse,maxobs,rthin,foreswp,aftswp) !$$$ subprogram documentation block ! . . . . @@ -424,9 +286,11 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! ! input argument list: ! flg - marks order of values in vertical dirction (1=increasing, -! -1=decreasing) +! -1=decreasing) +! save_all - logical - if true save all obs. (if false some unused values +! still get through) ! pflag - type of pressure-type levels; 0 : sigma level, 1 : determined by -! convinfo file +! convinfo file ! pcoord - veritical coordinate values ! nlevp - number of vertical levels ! dlat_earth - earth relative observation latitude (radians) @@ -434,15 +298,12 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! pob - observation pressure ob ! crit1 - quality indicator for observation (smaller = better) ! ithin - number of obs to retain per thinning grid box -! iin - counter of input data ! foreswp - if true, TDR scan is fore ! aftswp - if true, TDR scan is aft ! ! output argument list: ! iobs - observation counter -! iobsout- location for observation to be put ! iuse - .true. if observation should be used -! iiout - counter of data replaced ! attributes: ! language: f90 ! machine: ibm rs/6000 sp @@ -452,15 +313,15 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io implicit none logical ,intent( out) :: iuse - integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,iin,maxobs + logical ,intent(in ) :: save_all + integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,maxobs integer(i_kind) ,intent(inout) :: iobs - integer(i_kind) ,intent( out) :: iobsout,iiout - real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob,usage + real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob real(r_kind),dimension(nlevp),intent(in ) :: pcoord - real(r_kind),dimension(maxobs),intent(inout ) :: rusage + logical,dimension(maxobs), intent(inout) :: rthin integer(i_kind):: ip,itx - integer(i_kind) ix,iy + integer(i_kind) ix,iy,itmp real(r_kind) dlat1,dlon1,pob1 real(r_kind) dx,dy,dp @@ -468,14 +329,11 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io logical foreswp, aftswp - iiout = 0 + iuse=.true. ! If using all data (no thinning), simply return to calling routine if(use_all)then - iuse=.true. iobs=iobs+1 - iobsout=iobs - rusage(iobs)=usage return end if @@ -516,7 +374,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Examine various cases regarding what to do with current obs. ! Start by assuming observation will be selected. - iuse=.true. ! Determine "score" for observation. Lower score is better. ! crit = crit1*dist1 @@ -524,96 +381,95 @@ 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 + if(.not. setfore)call createfore - 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 + if (.not. icount_fore(itx,ip)) then + iobs=iobs+1 score_crit_fore(itx,ip)= crit - icount_fore(itx,ip)=icount_fore(itx,ip)+1 - ibest_obs(itx,ip) = iobs - rusage(iobs)=usage - ibest_save(itx,ip)=iin + icount_fore(itx,ip)=.true. + ibest_obs_fore(itx,ip) = iobs ! 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 - score_crit(itx,ip)= crit -! iobsout=ibest_obs(itx,ip) - icount(itx,ip)=icount(itx,ip)+1 - iiout = ibest_save(itx,ip) - rusage(iiout)=101.0_r_kind - rusage(iobs)=usage - ibest_save(itx,ip)=iobs + elseif (icount_fore(itx,ip) .and. crit < score_crit_fore(itx,ip)) then + iobs=iobs+1 + itmp=ibest_obs_fore(itx,ip) + rthin(itmp)=.true. + score_crit_fore(itx,ip)= crit + ibest_obs_fore(itx,ip)=iobs ! Case(3): obs score > best value at this location, -! Case(4): none of the above cases are satisified, don't use this obs ! --> do not use this obs, return to calling program. else - rusage(iobs)=101.1_r_kind - iuse=.false. + if(save_all)then + iobs=iobs+1 + rthin(iobs)=.true. + else + iuse=.false. + end if endif ! cases else if(aftswp) then ! aft sweeps + if(.not. setaft)call createaft - 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 + if (.not. icount_aft(itx,ip)) then + iobs=iobs+1 score_crit_aft(itx,ip)= crit - icount_aft(itx,ip)=icount_aft(itx,ip)+1 - ibest_obs(itx,ip) = iobs - ibest_save(itx,ip) = iin + icount_aft(itx,ip)=.true. + ibest_obs_aft(itx,ip) = iobs ! 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 + elseif (icount_aft(itx,ip) .and. crit < score_crit_aft(itx,ip)) then + iobs=iobs+1 + itmp=ibest_obs_aft(itx,ip) + rthin(itmp)=.true. score_crit_aft(itx,ip)= crit - icount_aft(itx,ip)=icount_aft(itx,ip)+1 - iobsout=ibest_obs(itx,ip) - iiout = ibest_save(itx,ip) - ibest_save(itx,ip)=iobs - rusage(iobs)=usage + ibest_obs_aft(itx,ip)=iobs ! 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. else - iuse = .false. - rusage(iobs)=101.1_r_kind + if(save_all)then + iobs=iobs+1 + rthin(iobs)=.true. + else + iuse=.false. + end if endif ! cases else - iobs=iobs+1 - iobsout=iobs + if(.not. setnormal)call createnormal ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - if (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then + if (icount(itx,ip) .and. crit < score_crit(itx,ip)) then + iobs=iobs+1 + itmp=ibest_obs(itx,ip) + rthin(itmp)=.true. score_crit(itx,ip)= crit - icount(itx,ip)=icount(itx,ip)+1 - iiout = ibest_obs(itx,ip) - ibest_save(itx,ip)=iin ibest_obs(itx,ip)=iobs - rusage(iiout)=101.0_r_kind - rusage(iobs)=usage ! Case: first obs at this location, ! --> keep this obs as starting point - elseif (icount(itx,ip)==0) then + elseif (.not. icount(itx,ip)) then + iobs=iobs+1 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 + ibest_obs(itx,ip)=iobs + icount(itx,ip)=.true. ! 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. - rusage(iobs)=101.0_r_kind + if(save_all)then + iobs=iobs+1 + rthin(iobs)=.true. + else + iuse=.false. + end if end if end if return @@ -621,8 +477,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io end subroutine map3grids_m - - subroutine del3grids !$$$ subprogram documentation block ! . . . . @@ -648,14 +502,24 @@ subroutine del3grids if (.not.use_all) then deallocate(mlon,glat,glon,hll) - deallocate(icount) - deallocate(icount_fore) - deallocate(icount_aft) - deallocate(ibest_obs) - deallocate(ibest_save) - deallocate(score_crit) - deallocate(score_crit_fore) - deallocate(score_crit_aft) + if(setnormal)then + deallocate(icount) + deallocate(ibest_obs) + deallocate(score_crit) + setnormal=.false. + end if + if(setfore)then + deallocate(icount_fore) + deallocate(score_crit_fore) + deallocate(ibest_obs_fore) + setfore=.false. + end if + if(setaft)then + deallocate(icount_aft) + deallocate(ibest_obs_aft) + deallocate(score_crit_aft) + setaft=.false. + end if endif end subroutine del3grids diff --git a/src/gsi/convthin_time.f90 b/src/gsi/convthin_time.f90 index 7f36caf09a..ae2a7bb6c3 100644 --- a/src/gsi/convthin_time.f90 +++ b/src/gsi/convthin_time.f90 @@ -8,7 +8,6 @@ module convthin_time ! ! subroutines included: ! make3grids_tm -! map3grids_tm ! map3grids_m_tm ! del3grids_tm ! @@ -27,24 +26,25 @@ module convthin_time private ! set subroutines to public public :: make3grids_tm - public :: map3grids_tm public :: map3grids_m_tm public :: del3grids_tm ! set passed variables to public public :: use_all_tm - integer(i_kind):: mlat + integer(i_kind):: mlat,nlevp,ntm,itxmax integer(i_kind),allocatable,dimension(:):: mlon - integer(i_kind),allocatable,dimension(:,:,:):: icount_tm,icount_fore_tm,icount_aft_tm,ibest_obs_tm,ibest_save_tm + logical ,allocatable,dimension(:,:,:):: icount_tm,icount_fore_tm,icount_aft_tm + integer(i_kind),allocatable,dimension(:,:,:):: ibest_obs_tm,ibest_obs_aft_tm,ibest_obs_fore_tm real(r_kind),allocatable,dimension(:):: glat real(r_kind),allocatable,dimension(:,:):: glon,hll real(r_kind),allocatable,dimension(:,:,:):: score_crit_tm,score_crit_fore_tm,score_crit_aft_tm logical use_all_tm + logical setfore,setaft,setnormal contains - subroutine make3grids_tm(rmesh,nlevp,ntm) + subroutine make3grids_tm(rmesh,nlevpp,ntmm) !$$$ subprogram documentation block ! . . . . ! subprogram: make3grids_tm @@ -59,8 +59,8 @@ subroutine make3grids_tm(rmesh,nlevp,ntm) ! rmesh - mesh size (km) of thinning grid. If (rmesh <= one), ! then no thinning of the data will occur. Instead, ! all data will be used without thinning. -! nlevp - vertical levels -! ntm - tm dimension relative to analysis tm +! nlevpp - vertical levels +! ntmm - tm dimension relative to analysis tm ! ! attributes: ! language: f90 @@ -73,13 +73,13 @@ subroutine make3grids_tm(rmesh,nlevp,ntm) implicit none real(r_kind) ,intent(in ) :: rmesh - integer(i_kind),intent(in ) :: nlevp - integer(i_kind),intent(in ) :: ntm + integer(i_kind),intent(in ) :: nlevpp + integer(i_kind),intent(in ) :: ntmm real(r_kind),parameter:: r360 = 360.0_r_kind - integer(i_kind) i,j,it - integer(i_kind) mlonx,mlonj,itxmax + integer(i_kind) i,j + integer(i_kind) mlonx,mlonj real(r_kind) delonx,delat,dgv,halfpi,dx,dy real(r_kind) twopi @@ -95,6 +95,8 @@ subroutine make3grids_tm(rmesh,nlevp,ntm) end if ! Set constants + ntm=ntmm + nlevp=nlevpp halfpi = half*pi twopi = two*pi rkm2dg = r360/(twopi*rearth_equator)*1.e3_r_kind @@ -124,7 +126,7 @@ subroutine make3grids_tm(rmesh,nlevp,ntm) factor = abs(cos(abs(glatm))) if (rmesh>zero) then - mlonj = nint(mlonx*factor) + mlonj = nint(mlonx*factor) mlon(j) = max(2,mlonj) delon = dlon_grid/mlon(j) else @@ -145,238 +147,114 @@ subroutine make3grids_tm(rmesh,nlevp,ntm) end do ! Allocate and initialize arrays + setnormal=.false. + setfore=.false. + setaft=.false. + + return + end subroutine make3grids_tm + subroutine createnormal_tm +!$$$ subprogram documentation block +! . . . . +! subprogram: createnormal +! prgmmr: derber org: np23 date: 2023-10-20 +! +! abstract: This routine creates and initializes arrays for normal thinning +! +! program history log: +! 2023-10-20 derber +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + integer i,j,it allocate(icount_tm(itxmax,nlevp,ntm)) - allocate(icount_fore_tm(itxmax,nlevp,ntm)) - allocate(icount_aft_tm(itxmax,nlevp,ntm)) allocate(ibest_obs_tm(itxmax,nlevp,ntm)) - allocate(ibest_save_tm(itxmax,nlevp,ntm)) allocate(score_crit_tm(itxmax,nlevp,ntm)) - allocate(score_crit_fore_tm(itxmax,nlevp,ntm)) - allocate(score_crit_aft_tm(itxmax,nlevp,ntm)) do j=1,nlevp do i=1,itxmax do it=1,ntm - icount_tm(i,j,it) = 0 - icount_fore_tm(i,j,it) = 0 - icount_aft_tm(i,j,it) = 0 + icount_tm(i,j,it) = .false. ibest_obs_tm(i,j,it)= 0 - ibest_save_tm(i,j,it)= 0 score_crit_tm(i,j,it)= 9.99e6_r_kind - score_crit_fore_tm(i,j,it)= 9.99e6_r_kind - score_crit_aft_tm(i,j,it)= 9.99e6_r_kind end do end do end do - + setnormal=.true. return - end subroutine make3grids_tm - - subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& - pob,itm,crit1,iobs,iobsout,iin,iiout,iuse,foreswp,aftswp) - + end subroutine createnormal_tm + subroutine createfore_tm !$$$ subprogram documentation block ! . . . . -! subprogram: map3grids_tm -! prgmmr: Su org: np23 date: 2013-11-20 +! subprogram: createfore_tm +! prgmmr: derber org: np23 date: 2023-10-20 ! -! abstract: This routine maps convential observations to a 3d thinning grid. +! abstract: This routine creates and initializes arrays for fore thinning ! ! program history log: +! 2023-10-20 derber ! -! input argument list: -! flg - marks order of values in vertical dirction (1=increasing, -1=decreasing) -! pflag - type of pressure-type levels; 0 : sigma level, 1 : determined by convinfo file -! pcoord - veritical coordinate values -! nlevp - number of vertical levels -! dlat_earth - earth relative observation latitude (radians) -! dlon_earth - earth relative observation longitude (radians) -! pob - observation pressure ob -! crit1 - quality indicator for observation (smaller = better) -! ithin - number of obs to retain per thinning grid box -! iin - counter of input data -! itm - tm count +! attributes: +! language: f90 +! machine: ibm rs/6000 sp ! -! output argument list: -! iobs - observation counter -! itx - combined (i,j) index of observation on thinning grid -! iobsout- location for observation to be put -! ip - vertical index -! iuse - .true. if observation should be used -! iiout - counter of data replaced -! +!$$$ + integer i,j,it + allocate(icount_fore_tm(itxmax,nlevp,ntm)) + allocate(ibest_obs_fore_tm(itxmax,nlevp,ntm)) + allocate(score_crit_fore_tm(itxmax,nlevp,ntm)) + + do j=1,nlevp + do i=1,itxmax + do it=1,ntm + icount_fore_tm(i,j,it) = .false. + ibest_obs_fore_tm(i,j,it)= 0 + score_crit_fore_tm(i,j,it)= 9.99e6_r_kind + end do + end do + end do + setfore=.true. + return + end subroutine createfore_tm + subroutine createaft_tm +!$$$ subprogram documentation block +! . . . . +! subprogram: createaft +! prgmmr: derber org: np23 date: 2023-10-20 +! +! abstract: This routine creates and initializes arrays for aft thinning +! +! program history log: +! 2023-10-20 derber ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ - use constants, only: one, half,two,three - implicit none - - logical ,intent( out) :: iuse - integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,iin,itm - integer(i_kind) ,intent(inout) :: iobs - integer(i_kind) ,intent( out) :: iobsout,iiout - real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob - - real(r_kind),dimension(nlevp),intent(in ) :: pcoord - - integer(i_kind):: ip,itx - integer(i_kind) ix,iy - - real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp -! real(r_kind) dxx,dyy,dpp - real(r_kind) crit!,dist1 - logical foreswp, aftswp - - - iiout = 0 - -! If using all data (no thinning), simply return to calling routine - if(use_all_tm)then - iuse=.true. - iobs=iobs+1 - iobsout=iobs - return - end if - -! Compute (i,j,k) indices of coarse mesh grid (grid number 1) which -! contains the current observation. - dlat1=dlat_earth - dlon1=dlon_earth - pob1=pob - - call grdcrd1(pob1,pcoord,nlevp,flg) - ip=int(pob1) - dp=pob1-ip - ip=max(1,min(ip,nlevp)) - - call grdcrd1(dlat1,glat,mlat,1) - iy=int(dlat1) - dy=dlat1-iy - iy=max(1,min(iy,mlat)) - - call grdcrd1(dlon1,glon(1,iy),mlon(iy),1) - ix=int(dlon1) - 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 - - itx=hll(ix,iy) - -! Compute distance metric (smaller is closer to center of cube) -! dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half - - -! Examine various cases regarding what to do with current obs. -! Start by assuming observation will be selected. - iuse=.true. - -! Determine "score" for observation. Lower score is better. -! crit = crit1*dist1 - crit = crit1 - -! TDR fore (Pseudo-dual-Doppler-radars) - if(foreswp) then ! fore sweeps - -! Case(1): first obs at this location, keep this obs as starting point - if (icount_fore_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs - score_crit_fore_tm(itx,ip,itm)= crit - icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1 - ibest_obs_tm(itx,ip,itm) = iobs - ibest_save_tm(itx,ip,itm) = iin - -! Case(2): 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 - score_crit_fore_tm(itx,ip,itm)= crit - icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1 - iobsout=ibest_obs_tm(itx,ip,itm) - iiout = ibest_save_tm(itx,ip,itm) - ibest_save_tm(itx,ip,itm)=iin - -! Case(3): obs score > best value at this location, -! 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 - -! TDR aft (Pseudo-dual-Doppler-radars) - else if(aftswp) then ! aft sweeps - -! Case(1): first obs at this location, keep this obs as starting point - if (icount_aft_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs - score_crit_aft_tm(itx,ip,itm)= crit - icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 - ibest_obs_tm(itx,ip,itm) = iobs - ibest_save_tm(itx,ip,itm) = iin - - -! Case(2): obs score < best value at this location, -! --> update score, count, and best obs counters - elseif (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then - score_crit_aft_tm(itx,ip,itm)= crit - icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 - iobsout=ibest_obs_tm(itx,ip,itm) - iiout = ibest_save_tm(itx,ip,itm) - ibest_save_tm(itx,ip,itm)=iin - -! 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. - else - iuse = .false. - endif ! cases - - else - -! Case: obs score < best value at this location, -! --> update score, count, and best obs counters - 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 - iiout = ibest_save_tm(itx,ip,itm) - ibest_save_tm(itx,ip,itm)=iin - -! Case: first obs at this location, -! --> keep this obs as starting point - elseif (icount_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs - score_crit_tm(itx,ip,itm)= crit - ibest_obs_tm(itx,ip,itm) = iobs - icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 - ibest_save_tm(itx,ip,itm) = iin - -! Case: obs score > best value at this location, -! Case: none of the above cases are satisified, -! --> do not use this obs, return to calling program. - else - iuse = .false. - end if - end if + integer i,j,it + allocate(icount_aft_tm(itxmax,nlevp,ntm)) + allocate(ibest_obs_aft_tm(itxmax,nlevp,ntm)) + allocate(score_crit_aft_tm(itxmax,nlevp,ntm)) + do j=1,nlevp + do i=1,itxmax + do it=1,ntm + icount_aft_tm(i,j,it) = .false. + ibest_obs_aft_tm(i,j,it)= 0 + score_crit_aft_tm(i,j,it)= 9.99e6_r_kind + end do + end do + end do + setaft=.true. return + end subroutine createaft_tm - end subroutine map3grids_tm - - subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,crit1,iobs,& - iobsout,iin,iiout,iuse,maxobs,usage,rusage,foreswp,aftswp) + subroutine map3grids_m_tm(flg,save_all,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,crit1,iobs,& + iuse,maxobs,rthin,foreswp,aftswp) !$$$ subprogram documentation block ! . . . . ! subprogram: map3grids_m_tm @@ -407,16 +285,14 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! pob - observation pressure ob ! crit1 - quality indicator for observation (smaller = better) ! ithin - number of obs to retain per thinning grid box -! iin - counter of input data +! save_all - flag to save all data (if false, some unused data will still + ! be saved. ! ! output argument list: ! iobs - observation counter ! itx - combined (i,j) index of observation on thinning grid -! iobsout- location for observation to be put ! ip - vertical index ! iuse - .true. if observation should be used -! iiout - counter of data replaced -! usage - data usage flag, 0 to keep, 101.0 not to keep ! ! ! attributes: @@ -428,15 +304,15 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c implicit none logical ,intent( out) :: iuse - integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,iin,maxobs,itm + logical ,intent(in ) :: save_all + integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,maxobs,itm integer(i_kind) ,intent(inout) :: iobs - integer(i_kind) ,intent( out) :: iobsout,iiout - real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob,usage + real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob real(r_kind),dimension(nlevp),intent(in ) :: pcoord - real(r_kind),dimension(maxobs),intent(inout ) :: rusage + logical,dimension(maxobs) ,intent(inout) :: rthin integer(i_kind):: ip,itx - integer(i_kind) ix,iy + integer(i_kind) ix,iy,itmp real(r_kind) dlat1,dlon1,pob1 real(r_kind) dx,dy,dp @@ -445,14 +321,10 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c logical foreswp, aftswp - iiout = 0 - + iuse=.true. ! If using all data (no thinning), simply return to calling routine if(use_all_tm)then - iuse=.true. iobs=iobs+1 - iobsout=iobs - rusage(iobs)=usage return end if @@ -493,7 +365,6 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Examine various cases regarding what to do with current obs. ! Start by assuming observation will be selected. - iuse=.true. ! Determine "score" for observation. Lower score is better. ! crit = crit1*dist1 @@ -501,98 +372,98 @@ 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 + if(.not.setfore)call createfore_tm ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - iobs=iobs+1 - iobsout=iobs - if (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then + if (icount_fore_tm(itx,ip,itm) .and. crit < score_crit_fore_tm(itx,ip,itm)) then + iobs=iobs+1 + itmp=ibest_obs_fore_tm(itx,ip,itm) + rthin(itmp)=.true. + ibest_obs_fore_tm(itx,ip,itm)=iobs 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 - iiout = ibest_save_tm(itx,ip,itm) - rusage(iiout)=101.1_r_kind - rusage(iobs)=usage - ibest_save_tm(itx,ip,itm)=iobs ! Case: first obs at this location, ! --> keep this obs as starting point - elseif (icount_fore_tm(itx,ip,itm)==0) then - rusage(iobs)=usage + elseif (.not. icount_fore_tm(itx,ip,itm)) then + iobs=iobs+1 score_crit_fore_tm(itx,ip,itm)= crit - ibest_obs_tm(itx,ip,itm) = iobs - icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1 - ibest_save_tm(itx,ip,itm) = iobs + ibest_obs_fore_tm(itx,ip,itm) = iobs + icount_fore_tm(itx,ip,itm)=.true. ! Case: none of the above cases are satisified, ! Case: obs score > best value at this location, ! --> do not use this obs, return to calling program. else - iuse = .false. - rusage(iobs)=101.0_r_kind + if(save_all)then + iobs=iobs+1 + rthin(iobs)=.true. + else + iuse=.false. + end if end if ! TDR aft (Pseudo-dual-Doppler-radars) else if(aftswp) then ! fore sweeps - iobs=iobs+1 - iobsout=iobs + if(.not.setaft)call createaft_tm ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - if (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then + if (icount_aft_tm(itx,ip,itm) .and. crit < score_crit_aft_tm(itx,ip,itm)) then + iobs=iobs+1 + itmp=ibest_obs_aft_tm(itx,ip,itm) + rthin(itmp)=.true. 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 - iiout = ibest_save_tm(itx,ip,itm) - rusage(iiout)=101.0_r_kind - rusage(iobs)=usage - ibest_save_tm(itx,ip,itm)=iobs + ibest_obs_aft_tm(itx,ip,itm)=iobs ! Case: first obs at this location, ! --> keep this obs as starting point - elseif (icount_aft_tm(itx,ip,itm)==0) then - rusage(iobs)=usage + elseif (.not. icount_aft_tm(itx,ip,itm)) then + iobs=iobs+1 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 + ibest_obs_aft_tm(itx,ip,itm) = iobs + icount_aft_tm(itx,ip,itm)=.true. ! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, ! --> do not use this obs, return to calling program. else - iuse = .false. - rusage(iobs)=101.1_r_kind + if(save_all)then + iobs=iobs+1 + rthin(iobs)=.true. + else + iuse=.false. + end if end if else - iobs=iobs+1 - iobsout=iobs + if(.not.setnormal)call createnormal_tm ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - if (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then + if (icount_tm(itx,ip,itm) .and. crit < score_crit_tm(itx,ip,itm)) then + iobs=iobs+1 + itmp=ibest_obs_tm(itx,ip,itm) + rthin(itmp)=.true. score_crit_tm(itx,ip,itm)= crit - icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 - iiout = ibest_obs_tm(itx,ip,itm) - rusage(iiout)=101.0_r_kind - rusage(iobs)=usage - ibest_save_tm(itx,ip,itm)=iin - ibest_obs_tm(itx,ip,itm)=iobs + ibest_obs_tm(itx,ip,itm) = iobs ! Case: first obs at this location, ! --> keep this obs as starting point - elseif (icount_tm(itx,ip,itm)==0) then - 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 + elseif (.not. icount_tm(itx,ip,itm)) then + iobs=iobs+1 + icount_tm(itx,ip,itm)=.true. + score_crit_tm(itx,ip,itm)= crit + ibest_obs_tm(itx,ip,itm)=iobs ! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, ! --> do not use this obs, return to calling program. else - iuse = .false. - rusage(iobs)=101.0_r_kind + if(save_all)then + iobs=iobs+1 + rthin(iobs)=.true. + else + iuse=.false. + end if end if end if @@ -625,14 +496,24 @@ subroutine del3grids_tm if (.not.use_all_tm) then deallocate(mlon,glat,glon,hll) - deallocate(icount_tm) - deallocate(icount_fore_tm) - deallocate(icount_aft_tm) - deallocate(ibest_obs_tm) - deallocate(ibest_save_tm) - deallocate(score_crit_tm) - deallocate(score_crit_fore_tm) - deallocate(score_crit_aft_tm) + if(setnormal)then + deallocate(icount_tm) + deallocate(ibest_obs_tm) + deallocate(score_crit_tm) + setnormal=.false. + end if + if(setfore)then + deallocate(icount_fore_tm) + deallocate(ibest_obs_fore_tm) + deallocate(score_crit_fore_tm) + setfore=.false. + end if + if(setaft)then + deallocate(icount_aft_tm) + deallocate(ibest_obs_aft_tm) + deallocate(score_crit_aft_tm) + setaft=.false. + end if endif end subroutine del3grids_tm diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 81fb684a73..512560f278 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -1,5 +1,5 @@ module get_fv3_regional_ensperts_mod -use abstract_get_fv3_regional_ensperts_mod,only: abstract_get_fv3_regional_ensperts_class + use abstract_get_fv3_regional_ensperts_mod,only: abstract_get_fv3_regional_ensperts_class use kinds, only : i_kind use general_sub2grid_mod, only: sub2grid_info use constants, only:max_varname_length diff --git a/src/gsi/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90 index 0e64c9a357..300d36cffb 100644 --- a/src/gsi/deter_sfc_mod.f90 +++ b/src/gsi/deter_sfc_mod.f90 @@ -156,7 +156,7 @@ subroutine deter_sfc(alat,alon,dlat_earth,dlon_earth,obstime,isflg, & if(iyp==nlon_sfc+1) iyp=1 ! Get time interpolation factors for surface files - if(obstime > hrdifsfc(1) .and. obstime <= hrdifsfc(nfldsfc))then + if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then do j=1,nfldsfc-1 if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then itsfc=j @@ -464,7 +464,7 @@ subroutine deter_sfc_type(dlat_earth,dlon_earth,obstime,isflg,tsavg) if(iyp==nlon_sfc+1) iyp=1 ! Get time interpolation factors for surface files - if(obstime > hrdifsfc(1) .and. obstime <= hrdifsfc(nfldsfc))then + if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then do j=1,nfldsfc-1 if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then itsfc=j @@ -600,7 +600,7 @@ subroutine deter_sfc2(dlat_earth,dlon_earth,obstime,idomsfc,tsavg,ff10,sfcr,zz) ! Get time interpolation factors for surface files - if(obstime > hrdifsfc(1) .and. obstime <= hrdifsfc(nfldsfc))then + if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then do j=1,nfldsfc-1 if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then itsfc=j @@ -821,7 +821,7 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,& ! Get time interpolation factors for surface files - if(obstime > hrdifsfc(1) .and. obstime <= hrdifsfc(nfldsfc))then + if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then do j=1,nfldsfc-1 if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then itsfc=j diff --git a/src/gsi/ensctl2model.f90 b/src/gsi/ensctl2model.f90 index 12e1fe374e..8a042a1e6a 100644 --- a/src/gsi/ensctl2model.f90 +++ b/src/gsi/ensctl2model.f90 @@ -52,7 +52,7 @@ subroutine ensctl2model(xhat,mval,eval) type(gsi_bundle) , intent(inout) :: eval(ntlevs_ens) ! Declare local variables -character(len=*),parameter::myname='ensctl2state' +character(len=*),parameter::myname='ensctl2model' character(len=max_varname_length),allocatable,dimension(:) :: clouds integer(i_kind) :: jj,ic,id,istatus,nclouds,nn @@ -140,7 +140,7 @@ subroutine ensctl2model(xhat,mval,eval) eval(jj)%values=zero ! Create a temporary bundle similar to xhat, and copy contents of xhat into it - call gsi_bundlecreate ( wbundle_c, xhat%step(1), 'ensctl2state work', istatus ) + call gsi_bundlecreate ( wbundle_c, xhat%step(1), 'ensctl2model work', istatus ) if(istatus/=0) then write(6,*) trim(myname), ': trouble creating work bundle' call stop2(999) diff --git a/src/gsi/ensctl2model_ad.f90 b/src/gsi/ensctl2model_ad.f90 index 706dafc59c..4adf4486f2 100644 --- a/src/gsi/ensctl2model_ad.f90 +++ b/src/gsi/ensctl2model_ad.f90 @@ -51,7 +51,7 @@ subroutine ensctl2model_ad(eval,mval,grad) type(gsi_bundle) , intent(in ) :: eval(ntlevs_ens) ! Declare local variables -character(len=*),parameter::myname='ensctl2state' +character(len=*),parameter::myname='ensctl2model_ad' character(len=max_varname_length),allocatable,dimension(:) :: clouds integer(i_kind) :: ii,jj,ic,id,istatus,nclouds,nn diff --git a/src/gsi/ensctl2state.f90 b/src/gsi/ensctl2state.f90 index bd72e12b76..4afc87d56e 100644 --- a/src/gsi/ensctl2state.f90 +++ b/src/gsi/ensctl2state.f90 @@ -1,4 +1,66 @@ -subroutine ensctl2state(xhat,mval,eval) +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !MODULE: ensctl2state_mod --- ensctl2state_mod variables and routines +! +! !INTERFACE: +! +module ensctl2state_mod + +! !USES: + + +! !DESCRIPTION: module ensctl2state routines and variables + + +use constants, only: zero,max_varname_length +use kinds, only: r_kind,i_kind +use control_vectors, only: control_vector,cvars3d,e2sset_flg +use gsi_4dvar, only: ibin_anl +use hybrid_ensemble_parameters, only: uv_hyb_ens,dual_res,ntlevs_ens,q_hyb_ens +use hybrid_ensemble_isotropic, only: ensemble_forward_model,ensemble_forward_model_dual_res +use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad,ensemble_forward_model_ad_dual_res +use balmod, only: strong_bk,strong_bk_ad +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: self_add +use gsi_bundlemod, only: assignment(=) +use mpeu_util, only: getindex +use gsi_metguess_mod, only: gsi_metguess_get +use mod_strong, only: tlnmc_option +use cwhydromod, only: cw2hydro_tl,cw2hydro_ad +use cwhydromod, only: cw2hydro_tl_hwrf,cw2hydro_ad_hwrf +use timermod, only: timer_ini,timer_fnl +use gridmod, only: nems_nmmb_regional + +implicit none + +private +public :: ensctl2state,ensctl2state_ad + +logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi +logical :: ls_qr,ls_qs,ls_qg,ls_qh +logical :: ls_w,ls_dw + +logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh,lc_cw +logical :: lc_w,lc_dw + +logical :: do_getuv,do_tv_to_tsen,do_normal_rh_to_q,do_getprs,lstrong_bk_vars +logical :: do_q_copy +logical :: do_cw_to_hydro +logical :: do_cw_to_hydro_hwrf + +integer(i_kind) :: nclouds,idozone,istatus + + +contains + subroutine ensctl2state(xhat,mval,eval) !$$$ subprogram documentation block ! . . . . ! subprogram: ensctl2state @@ -25,28 +87,6 @@ subroutine ensctl2state(xhat,mval,eval) ! !$$$ end documentation block -use constants, only: zero,max_varname_length -use kinds, only: r_kind,i_kind -use control_vectors, only: control_vector,cvars3d -use gsi_4dvar, only: ibin_anl -use hybrid_ensemble_parameters, only: uv_hyb_ens,dual_res,ntlevs_ens,q_hyb_ens -use hybrid_ensemble_isotropic, only: ensemble_forward_model,ensemble_forward_model_dual_res -use balmod, only: strong_bk -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: self_add -use gsi_bundlemod, only: assignment(=) -use mpeu_util, only: getindex -use gsi_metguess_mod, only: gsi_metguess_get -use mod_strong, only: tlnmc_option -use cwhydromod, only: cw2hydro_tl -use cwhydromod, only: cw2hydro_tl_hwrf -use timermod, only: timer_ini,timer_fnl -use gridmod, only: nems_nmmb_regional implicit none ! Declare passed variables @@ -57,28 +97,14 @@ subroutine ensctl2state(xhat,mval,eval) ! Declare local variables character(len=*),parameter::myname='ensctl2state' character(len=max_varname_length),allocatable,dimension(:) :: clouds -integer(i_kind) :: jj,ic,id,istatus,nclouds +integer(i_kind) :: jj,ic,id +logical :: do_tlnmc -integer(i_kind), parameter :: ncvars = 8 -integer(i_kind) :: icps(ncvars) type(gsi_bundle):: wbundle_c ! work bundle -character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here - 'sf ', 'vp ', 'ps ', 't ', & - 'q ', 'cw ', 'w ', 'dw '/) -logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh,lc_cw -logical :: lc_w,lc_dw real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() ! Declare required local state variables -integer(i_kind), parameter :: nsvars = 13 -integer(i_kind) :: isps(nsvars) -character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ','qi ', & - 'qr ', 'qs ', 'qg ', 'qh ', 'w ', 'dw ' /) -logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi -logical :: ls_qr,ls_qs,ls_qg,ls_qh -logical :: ls_w,ls_dw real(r_kind),pointer,dimension(:,:) :: sv_ps=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_sst=>NULL() real(r_kind),pointer,dimension(:,:,:) :: sv_u=>NULL() @@ -92,50 +118,20 @@ subroutine ensctl2state(xhat,mval,eval) real(r_kind),pointer,dimension(:,:,:) :: sv_w=>NULL() real(r_kind),pointer,dimension(:,:,:) :: sv_dw=>NULL() -logical :: do_getprs_tl,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,lstrong_bk_vars -logical :: do_tlnmc,do_q_copy -logical :: do_cw_to_hydro -logical :: do_cw_to_hydro_hwrf - ! **************************************************************************** ! Initialize timer ! call timer_ini(trim(myname)) +if(e2sset_flg)call ensctl2state_set(xhat,eval) + ! Inquire about cloud-vars -call gsi_metguess_get('clouds::3d',nclouds,istatus) if (nclouds>0) then allocate(clouds(nclouds)) call gsi_metguess_get('clouds::3d',clouds,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_w =icps(7)>0; lc_dw =icps(8)>0 -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus) -ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 -ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0; ls_qi =isps(7)>0 -ls_qr =isps(8)>0; ls_qs =isps(9)>0 -ls_qg =isps(10)>0; ls_qh =isps(11)>0 -ls_w =isps(12)>0; ls_dw =isps(13)>0 - -! Define what to do depending on what's in CV and SV -lstrong_bk_vars =lc_ps.and.lc_sf.and.lc_vp.and.lc_t -do_getprs_tl =lc_ps.and.lc_t .and.ls_prse -do_normal_rh_to_q=(.not.q_hyb_ens).and.& - lc_rh.and.lc_t .and.ls_prse.and.ls_q -do_q_copy=.false. -if(.not. do_normal_rh_to_q) then - do_q_copy = lc_rh.and.lc_t .and.ls_prse.and.ls_q.and.q_hyb_ens -end if -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 ! Create a temporary bundle similar to xhat, and copy contents of xhat into it call gsi_bundlecreate ( wbundle_c, xhat%step(1), 'ensctl2state work', istatus ) if(istatus/=0) then @@ -143,10 +139,6 @@ subroutine ensctl2state(xhat,mval,eval) call stop2(999) endif -do_cw_to_hydro = .false. -do_cw_to_hydro = lc_cw .and. ls_ql .and. ls_qi -do_cw_to_hydro_hwrf = .false. -do_cw_to_hydro_hwrf = lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh ! Initialize ensemble contribution to zero !$omp parallel do schedule(dynamic,1) private(jj) @@ -205,7 +197,7 @@ subroutine ensctl2state(xhat,mval,eval) if(do_q_copy) then call gsi_bundlegetvar ( wbundle_c, 'q', sv_q, istatus ) else - if(do_getprs_tl) call getprs_tl(sv_ps,sv_tv,sv_prse) + if(do_getprs) call getprs_tl(sv_ps,sv_tv,sv_prse) ! Convert RH to Q if(do_normal_rh_to_q) then @@ -239,26 +231,20 @@ subroutine ensctl2state(xhat,mval,eval) !$omp section -! Get pointers to required state variables +! Get pointers to required state variables and copy call gsi_bundlegetpointer (eval(jj),'sst' ,sv_sst, istatus) - if(ls_w)then + call gsi_bundlegetvar ( wbundle_c, 'sst', sv_sst, istatus ) + if(ls_w .and. lc_w)then call gsi_bundlegetpointer (eval(jj),'w' ,sv_w, istatus) - if(ls_dw.and.nems_nmmb_regional)then + call gsi_bundlegetvar ( wbundle_c, 'w' , sv_w, istatus ) + if(ls_dw .and. lc_dw)then call gsi_bundlegetpointer (eval(jj),'dw' ,sv_dw, istatus) + call gsi_bundlegetvar ( wbundle_c, 'dw' , sv_dw, istatus ) end if end if -! Copy variables - call gsi_bundlegetvar ( wbundle_c, 'sst', sv_sst, istatus ) - if(lc_w)then - call gsi_bundlegetvar ( wbundle_c, 'w' , sv_w, istatus ) - if(lc_dw.and.nems_nmmb_regional)then - call gsi_bundlegetvar ( wbundle_c, 'dw' , sv_dw, istatus ) - end if - end if ! Get the ozone vector if it is defined - id=getindex(cvars3d,"oz") - if(id > 0) then + if(idozone > 0) then call gsi_bundlegetpointer (eval(jj),'oz' ,sv_oz , istatus) call gsi_bundlegetvar ( wbundle_c, 'oz' , sv_oz, istatus ) endif @@ -275,7 +261,7 @@ subroutine ensctl2state(xhat,mval,eval) ! Need to update 3d pressure and sensible temperature again for consistency ! Get 3d pressure - if(do_getprs_tl) call getprs_tl(sv_ps,sv_tv,sv_prse) + if(do_getprs) call getprs_tl(sv_ps,sv_tv,sv_prse) end if @@ -297,3 +283,287 @@ subroutine ensctl2state(xhat,mval,eval) return end subroutine ensctl2state + +subroutine ensctl2state_set(xhat,eval) +! . . . . +! subprogram: ensctl2state_set +! prgmmr: derber +! +! abstract: Sets flags for ensctl2state and ensctl2state_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 + +type(control_vector), intent(in) :: xhat +type(gsi_bundle) , intent(in) :: eval(ntlevs_ens) + +integer(i_kind), parameter :: nsvars = 13 +integer(i_kind) :: isps(nsvars) +character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here + 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ','qi ', & + 'qr ', 'qs ', 'qg ', 'qh ', 'w ', 'dw ' /) +integer(i_kind), parameter :: ncvars = 8 +integer(i_kind) :: icps(ncvars) +character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here + 'sf ', 'vp ', 'ps ', 't ', & + 'q ', 'cw ', 'w ', 'dw '/) +! Inquire about cloud-vars +call gsi_metguess_get('clouds::3d',nclouds,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_w =icps(7)>0; lc_dw =icps(8)>0 + +! Since each internal vector of xhat has the same structure, pointers are +! the same independent of the subwindow jj +call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus) +ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 +ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0; ls_qi =isps(7)>0 +ls_qr =isps(8)>0; ls_qs =isps(9)>0 +ls_qg =isps(10)>0; ls_qh =isps(11)>0 +ls_w =isps(12)>0; ls_dw =isps(13)>0.and.nems_nmmb_regional + +! Define what to do depending on what's in CV and SV +lstrong_bk_vars =lc_ps.and.lc_sf.and.lc_vp.and.lc_t +do_getprs =lc_ps.and.lc_t .and.ls_prse +do_normal_rh_to_q=(.not.q_hyb_ens).and.& + lc_rh.and.lc_t .and.ls_prse.and.ls_q +if(.not. do_normal_rh_to_q) then + do_q_copy = lc_rh.and.lc_t .and.ls_prse.and.ls_q.and.q_hyb_ens +else + do_q_copy=.false. +end if +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 = 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 + + +idozone=getindex(cvars3d,"oz") + +e2sset_flg=.false. ! set to true in setup. set to false after first (only) call to ensctl2state_set + + +return +end subroutine ensctl2state_set +subroutine ensctl2state_ad(eval,mval,grad) +!$$$ subprogram documentation block +! . . . . +! subprogram: ensctl2state_ad +! prgmmr: kleist +! +! abstract: Contribution from state space to ensemble control vector +! +! program history log: +! 2011-11-17 kleist - initial code +! 2013-10-28 todling - rename p3d to prse +! 2013-11-22 kleist - add option for q perturbations +! 2014-12-03 derber - introduce parallel regions for optimization +! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu +! 2019-07-11 Todling - there should be no need to check on the existence of w and dw +! +! input argument list: +! eval - Ensemble state variable variable +! grad - Control variable +! +! output argument list: +! grad - Control variable +! +!$$$ end documentation block + +implicit none + +! Declare passed variables +type(control_vector), intent(inout) :: grad +type(gsi_bundle) , intent(inout) :: mval +type(gsi_bundle) , intent(in ) :: eval(ntlevs_ens) + +! Declare local variables +character(len=*),parameter::myname='ensctl2state_ad' +integer(i_kind) :: jj,ic,id +logical :: do_tlnmc + +character(len=max_varname_length),allocatable,dimension(:) :: clouds +type(gsi_bundle):: wbundle_c ! work bundle +real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() +! Declare required local state variables +real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_sst=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_v=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_prse=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_tsen=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_tv=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_oz=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_w=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_dw=>NULL() + +!**************************************************************************** + +! Initialize timer +!call timer_ini(trim(myname)) + +! Inquire about chemistry +if(e2sset_flg)call ensctl2state_set(grad,eval) +if (nclouds>0) then + allocate(clouds(nclouds)) + call gsi_metguess_get('clouds::3d',clouds,istatus) +endif + +! Initialize +mval%values=zero +! Create a temporary bundle similar to grad, and copy contents of grad into it +call gsi_bundlecreate ( wbundle_c, grad%step(1), 'ensctl2state_ad work', istatus ) +if(istatus/=0) then + write(6,*) trim(myname), ': trouble creating work bundle' + call stop2(999) +endif + +do jj=1,ntlevs_ens + +! If calling TLNMC, already have u,v (so set last argument to true) + do_tlnmc = lstrong_bk_vars .and. ( (tlnmc_option==3) .or. & + (jj==ibin_anl .and. tlnmc_option==2)) + + wbundle_c%values=zero + +! Get sv pointers here +! Get pointers to required state variables + call gsi_bundlegetpointer (eval(jj),'u' ,rv_u, istatus) + call gsi_bundlegetpointer (eval(jj),'v' ,rv_v, istatus) + call gsi_bundlegetpointer (eval(jj),'ps' ,rv_ps, istatus) + call gsi_bundlegetpointer (eval(jj),'prse',rv_prse,istatus) + call gsi_bundlegetpointer (eval(jj),'tv' ,rv_tv, istatus) + call gsi_bundlegetpointer (eval(jj),'tsen',rv_tsen,istatus) + call gsi_bundlegetpointer (eval(jj),'q' ,rv_q , istatus) + call gsi_bundlegetpointer (wbundle_c,'q' ,cv_rh ,istatus) + +! Adjoint of consistency for sensible temperature, calculate sensible temperature + if(do_tv_to_tsen) call tv_to_tsen_ad(rv_tv,rv_q,rv_tsen) + + if(do_tlnmc) then + + ! Adjoint to convert ps to 3-d pressure + if(do_getprs) call getprs_ad(rv_ps,rv_tv,rv_prse) + rv_prse=zero + + ! Adjoint of strong_bk + call strong_bk_ad(rv_u,rv_v,rv_ps,rv_tv,.true.) + + end if + + call self_add(mval,eval(jj)) + +!$omp parallel sections private(ic,id,istatus) + +!$omp section + +! Convert RHS calculations for u,v to st/vp + if (do_getuv) then + if(uv_hyb_ens) then + call gsi_bundleputvar ( wbundle_c, 'sf', rv_u, istatus ) + call gsi_bundleputvar ( wbundle_c, 'vp', rv_v, istatus ) + else + call gsi_bundlegetpointer (wbundle_c,'sf' ,cv_sf ,istatus) + call gsi_bundlegetpointer (wbundle_c,'vp' ,cv_vp ,istatus) + call getuv(rv_u,rv_v,cv_sf,cv_vp,1) + end if + end if + +!$omp section + + call gsi_bundlegetpointer (eval(jj),'sst' ,rv_sst, istatus) + call gsi_bundleputvar ( wbundle_c, 'sst', rv_sst, istatus ) + if(lc_w .and. ls_w)then + call gsi_bundlegetpointer (eval(jj),'w' ,rv_w, istatus) + call gsi_bundleputvar ( wbundle_c, 'w', rv_w, istatus ) + if(ls_dw .and. lc_dw)then + call gsi_bundlegetpointer (eval(jj),'dw' ,rv_dw, istatus) + call gsi_bundleputvar ( wbundle_c, 'dw', rv_dw, istatus ) + end if + end if + +! Get the ozone vector if it is defined + if(idozone > 0) then + call gsi_bundlegetpointer (eval(jj),'oz' ,rv_oz , istatus) + call gsi_bundleputvar ( wbundle_c, 'oz', rv_oz, istatus ) + endif + +!$omp section + + 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(eval(jj),wbundle_c,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(eval(jj),wbundle_c,rv_tsen) + else +! Since cloud-vars map one-to-one, take care of them together + do ic=1,nclouds + id=getindex(cvars3d,clouds(ic)) + if (id>0) then + call gsi_bundlegetpointer (eval(jj),clouds(ic),rv_rank3,istatus) + call gsi_bundleputvar (wbundle_c, clouds(ic),rv_rank3,istatus) + endif + enddo + endif + +! Calculate sensible temperature + if(do_q_copy) then + call gsi_bundleputvar (wbundle_c, 'q', rv_q, istatus ) + else + +! 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,rv_tv,rv_prse,rv_q) + +! Adjoint to convert ps to 3-d pressure + if(do_getprs) call getprs_ad(rv_ps,rv_tv,rv_prse) + end if + +! Adjoint of control to initial state + call gsi_bundleputvar ( wbundle_c, 't' , rv_tv, istatus ) + call gsi_bundleputvar ( wbundle_c, 'ps', rv_ps, istatus ) +! call gsi_bundleputvar ( wbundle_c, 'q' , zero, istatus ) !mjk +!$omp end parallel sections + + if(dual_res) then + call ensemble_forward_model_ad_dual_res(wbundle_c,grad%aens(1,:,:),jj) + else + call ensemble_forward_model_ad(wbundle_c,grad%aens(1,:,:),jj) + end if + +end do + +call gsi_bundledestroy(wbundle_c,istatus) +if (istatus/=0) then + write(6,*) trim(myname),': trouble destroying work bundle' + call stop2(999) +endif + +if (nclouds>0) deallocate(clouds) + +! Finalize timer +!call timer_fnl(trim(myname)) + +return +end subroutine ensctl2state_ad +end module ensctl2state_mod diff --git a/src/gsi/ensctl2state_ad.f90 b/src/gsi/ensctl2state_ad.f90 deleted file mode 100644 index d350743998..0000000000 --- a/src/gsi/ensctl2state_ad.f90 +++ /dev/null @@ -1,287 +0,0 @@ -subroutine ensctl2state_ad(eval,mval,grad) -!$$$ subprogram documentation block -! . . . . -! subprogram: ensctl2state_ad -! prgmmr: kleist -! -! abstract: Contribution from state space to ensemble control vector -! -! program history log: -! 2011-11-17 kleist - initial code -! 2013-10-28 todling - rename p3d to prse -! 2013-11-22 kleist - add option for q perturbations -! 2014-12-03 derber - introduce parallel regions for optimization -! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu -! 2019-07-11 Todling - there should be no need to check on the existence of w and dw -! -! input argument list: -! eval - Ensemble state variable variable -! grad - Control variable -! -! output argument list: -! grad - Control variable -! -!$$$ end documentation block - -use kinds, only: r_kind,i_kind -use control_vectors, only: control_vector,cvars3d -use gsi_4dvar, only: ibin_anl -use hybrid_ensemble_parameters, only: uv_hyb_ens,dual_res,ntlevs_ens,q_hyb_ens -use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad -use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad_dual_res -use balmod, only: strong_bk_ad -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_bundlemod, only : self_add -use constants, only: zero,max_varname_length -use mpeu_util, only: getindex -use gsi_metguess_mod, only: gsi_metguess_get -use mod_strong, only: tlnmc_option -use cwhydromod, only: cw2hydro_ad -use cwhydromod, only: cw2hydro_ad_hwrf -use timermod, only: timer_ini,timer_fnl -use gridmod, only: nems_nmmb_regional -implicit none - -! Declare passed variables -type(control_vector), intent(inout) :: grad -type(gsi_bundle) , intent(inout) :: mval -type(gsi_bundle) , intent(in ) :: eval(ntlevs_ens) - -! Declare local variables -character(len=*),parameter::myname='ensctl2state_ad' -character(len=max_varname_length),allocatable,dimension(:) :: clouds -integer(i_kind) :: jj,ic,id,istatus,nclouds - -integer(i_kind), parameter :: ncvars = 8 -integer(i_kind) :: icps(ncvars) -type(gsi_bundle):: wbundle_c ! work bundle -character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here - 'sf ', 'vp ', 'ps ', 't ', & - 'q ', 'cw ', 'w ', 'dw '/) -logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh,lc_cw -logical :: lc_w,lc_dw -real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() -! Declare required local state variables -integer(i_kind), parameter :: nsvars = 13 -integer(i_kind) :: isps(nsvars) -character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen','ql ','qi ', & - 'qr ', 'qs ', 'qg ', 'qh ', 'w ','dw ' /) -logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi -logical :: ls_qr,ls_qs,ls_qg,ls_qh -logical :: ls_w,ls_dw -real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_sst=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_v=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_prse=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_tsen=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_tv=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_oz=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_w=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_dw=>NULL() - -logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,lstrong_bk_vars -logical :: do_tlnmc,do_q_copy -logical :: do_cw_to_hydro_ad -logical :: do_cw_to_hydro_ad_hwrf -logical :: wdw_exist - -!**************************************************************************** - -! Initialize timer -!call timer_ini(trim(myname)) - -! Inquire about chemistry -call gsi_metguess_get('clouds::3d',nclouds,istatus) -if (nclouds>0) then - allocate(clouds(nclouds)) - call gsi_metguess_get('clouds::3d',clouds,istatus) -endif - -! Since each internal vector 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_w =icps(7)>0; lc_dw =icps(8)>0 - -! Since each internal vector of grad has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus) -ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 -ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0; ls_qi =isps(7)>0 -ls_qr =isps(8)>0; ls_qs =isps(9)>0 -ls_qg =isps(10)>0; ls_qh =isps(11)>0 -ls_w =isps(12)>0; ls_dw =isps(13)>0 - -! Define what to do depending on what's in CV and SV -lstrong_bk_vars =lc_sf.and.lc_vp.and.lc_ps .and.lc_t -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=(.not.q_hyb_ens).and.& - lc_t .and.lc_rh.and.ls_prse.and.ls_q -do_q_copy=.false. -if(.not. do_normal_rh_to_q_ad) then - do_q_copy = lc_rh.and.lc_t .and.ls_prse.and.ls_q.and.q_hyb_ens -end if -do_getprs_ad =lc_t .and.lc_ps.and.ls_prse - -do_cw_to_hydro_ad=.false. -do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi -do_cw_to_hydro_ad_hwrf=.false. -do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh - -wdw_exist = lc_w.and.lc_dw.and.ls_w.and.ls_dw - -! Initialize -mval%values=zero -! Create a temporary bundle similar to grad, and copy contents of grad into it -call gsi_bundlecreate ( wbundle_c, grad%step(1), 'ensctl2state_ad work', istatus ) -if(istatus/=0) then - write(6,*) trim(myname), ': trouble creating work bundle' - call stop2(999) -endif - -do jj=1,ntlevs_ens - -! If calling TLNMC, already have u,v (so set last argument to true) - do_tlnmc = lstrong_bk_vars .and. ( (tlnmc_option==3) .or. & - (jj==ibin_anl .and. tlnmc_option==2)) - - wbundle_c%values=zero - -! Get sv pointers here -! Get pointers to required state variables - call gsi_bundlegetpointer (eval(jj),'u' ,rv_u, istatus) - call gsi_bundlegetpointer (eval(jj),'v' ,rv_v, istatus) - call gsi_bundlegetpointer (eval(jj),'ps' ,rv_ps, istatus) - call gsi_bundlegetpointer (eval(jj),'prse',rv_prse,istatus) - call gsi_bundlegetpointer (eval(jj),'tv' ,rv_tv, istatus) - call gsi_bundlegetpointer (eval(jj),'tsen',rv_tsen,istatus) - call gsi_bundlegetpointer (eval(jj),'q' ,rv_q , istatus) - call gsi_bundlegetpointer (wbundle_c,'q' ,cv_rh ,istatus) - -! Adjoint of consistency for sensible temperature, calculate sensible temperature - if(do_tv_to_tsen_ad) call tv_to_tsen_ad(rv_tv,rv_q,rv_tsen) - - if(do_tlnmc) then - - ! Adjoint to convert ps to 3-d pressure - if(do_getprs_ad) call getprs_ad(rv_ps,rv_tv,rv_prse) - rv_prse=zero - - ! Adjoint of strong_bk - call strong_bk_ad(rv_u,rv_v,rv_ps,rv_tv,.true.) - - end if - - call self_add(mval,eval(jj)) - -!$omp parallel sections private(ic,id,istatus) - -!$omp section - -! Convert RHS calculations for u,v to st/vp - if (do_getuv) then - if(uv_hyb_ens) then - call gsi_bundleputvar ( wbundle_c, 'sf', rv_u, istatus ) - call gsi_bundleputvar ( wbundle_c, 'vp', rv_v, istatus ) - else - call gsi_bundlegetpointer (wbundle_c,'sf' ,cv_sf ,istatus) - call gsi_bundlegetpointer (wbundle_c,'vp' ,cv_vp ,istatus) - call getuv(rv_u,rv_v,cv_sf,cv_vp,1) - end if - end if - -!$omp section - - call gsi_bundlegetpointer (eval(jj),'sst' ,rv_sst, istatus) - call gsi_bundleputvar ( wbundle_c, 'sst', rv_sst, istatus ) - if(wdw_exist)then - call gsi_bundlegetpointer (eval(jj),'w' ,rv_w, istatus) - call gsi_bundleputvar ( wbundle_c, 'w', rv_w, istatus ) - if(nems_nmmb_regional)then - call gsi_bundlegetpointer (eval(jj),'dw' ,rv_dw, istatus) - call gsi_bundleputvar ( wbundle_c, 'dw', rv_dw, istatus ) - end if - end if - -! Get the ozone vector if it is defined - id=getindex(cvars3d,"oz") - if(id > 0) then - call gsi_bundlegetpointer (eval(jj),'oz' ,rv_oz , istatus) - call gsi_bundleputvar ( wbundle_c, 'oz', rv_oz, istatus ) - endif - -!$omp section - - if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then -! Case when cloud-vars do not map one-to-one -! e.g. cw-to-ql&qi - call cw2hydro_ad(eval(jj),wbundle_c,clouds,nclouds) - elseif (do_cw_to_hydro_ad_hwrf) then -!! Case when cloud-vars do not map one-to-one -!! e.g. cw-to-ql&qi&qr&qs&qg&qh - call cw2hydro_ad_hwrf(eval(jj),wbundle_c,rv_tsen) - else -! Since cloud-vars map one-to-one, take care of them together - do ic=1,nclouds - id=getindex(cvars3d,clouds(ic)) - if (id>0) then - call gsi_bundlegetpointer (eval(jj),clouds(ic),rv_rank3,istatus) - call gsi_bundleputvar (wbundle_c, clouds(ic),rv_rank3,istatus) - endif - enddo - endif - -! Calculate sensible temperature - if(do_q_copy) then - call gsi_bundleputvar (wbundle_c, 'q', rv_q, istatus ) - else - -! 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,rv_tv,rv_prse,rv_q) - -! Adjoint to convert ps to 3-d pressure - if(do_getprs_ad) call getprs_ad(rv_ps,rv_tv,rv_prse) - end if - -! Adjoint of control to initial state - call gsi_bundleputvar ( wbundle_c, 't' , rv_tv, istatus ) - call gsi_bundleputvar ( wbundle_c, 'ps', rv_ps, istatus ) -! call gsi_bundleputvar ( wbundle_c, 'q' , zero, istatus ) !mjk -!$omp end parallel sections - - if(dual_res) then - call ensemble_forward_model_ad_dual_res(wbundle_c,grad%aens(1,:,:),jj) - else - call ensemble_forward_model_ad(wbundle_c,grad%aens(1,:,:),jj) - end if - -end do - -call gsi_bundledestroy(wbundle_c,istatus) -if (istatus/=0) then - write(6,*) trim(myname),': trouble destroying work bundle' - call stop2(999) -endif - -if (nclouds>0) deallocate(clouds) - -! Finalize timer -!call timer_fnl(trim(myname)) - -return -end subroutine ensctl2state_ad diff --git a/src/gsi/general_commvars_mod.f90 b/src/gsi/general_commvars_mod.f90 index 4304eb6428..f171850373 100644 --- a/src/gsi/general_commvars_mod.f90 +++ b/src/gsi/general_commvars_mod.f90 @@ -19,8 +19,8 @@ module general_commvars_mod ! def s2g_raf - used for subdomain to horizontal grid transfers of full control vector with motley variables ! def s2g_cv - used in bkerror.f90 (full control vector without motley variables) ! def s2g2 - used in getprs.f90 -! def s2g4 - used in get_derivatives2.f90 -! def s1g4 - used in get_derivatives2.f90 (uv versions) +! def s2g4 - used in get_derivatives2.f90 +! def s1g4 - used in get_derivatives2.f90 ! def s2guv - used in getuv.f90 ! def s2g_d - used in get_derivatives.f90 ! def g1 - used in get_derivatives.f90 @@ -255,7 +255,8 @@ subroutine init_general_commvars num_fields=3*nsig+1 call general_sub2grid_create_info(g33p1,inner_vars,nlat,nlon,nsig,num_fields,regional,s_ref=s2g_raf) -! create general_sub2grid structure variable s2g4, which is used in get_derivatives2.f90 +! create general_sub2grid structure variable s2g4, which is used in +! get_derivatives2.f90 num_fields=2*nsig+1 inner_vars=2 diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index ca551efa21..ca5db84a1a 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -49,10 +49,9 @@ subroutine get_gefs_ensperts_dualres !$$$ end documentation block use mpeu_util, only: die - use gridmod, only: idsl5 use hybrid_ensemble_parameters, only: n_ens,write_ens_sprd,oz_univ_static,ntlevs_ens use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen - use constants,only: zero,zero_single,half,fv,rd_over_cp,one,qcmin + use constants,only: zero,zero_single,half,fv,one,qcmin use mpimod, only: mpi_comm_world,mype,npe use kinds, only: r_kind,i_kind,r_single use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens,limqens diff --git a/src/gsi/gsdcloudanalysis.F90 b/src/gsi/gsdcloudanalysis.F90 index 21fc21b8a2..6df710cf32 100644 --- a/src/gsi/gsdcloudanalysis.F90 +++ b/src/gsi/gsdcloudanalysis.F90 @@ -65,7 +65,7 @@ subroutine gsdcloudanalysis(mype) ! ! use constants, only: zero,one,rad2deg,fv - use constants, only: rd_over_cp, h1000 + use constants, only: rd_over_cp,h1000 use kinds, only: r_single,i_kind, r_kind use gridmod, only: pt_ll,eta1_ll,aeta1_ll,eta2_ll,aeta2_ll use gridmod, only: regional,wrf_mass_regional,regional_time diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index ce74d91c63..95d885e2ee 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -157,7 +157,6 @@ ens_spread_mod.f90 ensctl2model.f90 ensctl2model_ad.f90 ensctl2state.f90 -ensctl2state_ad.f90 evaljgrad.f90 evaljo.f90 evalqlim.f90 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index c8a2775863..7f0f00ac84 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -201,9 +201,11 @@ module gsi_rfv3io_mod contains subroutine fv3regfilename_init(this,it) implicit None + class(type_fv3regfilenameg),intent(inout):: this + integer(i_kind), intent(in ) :: it + character(255):: filename - integer(i_kind),intent(in) :: it if (it == ntguessig) then this%grid_spec='fv3_grid_spec' else @@ -293,11 +295,12 @@ subroutine gsi_rfv3io_get_grid_specs(ierr) use mpimod, only: mpi_comm_world,mpi_itype,mpi_rtype implicit none + integer(i_kind),intent( out) :: ierr + integer(i_kind) gfile_grid_spec character(:),allocatable :: grid_spec character(:),allocatable :: ak_bk character(len=:),allocatable :: coupler_res_filenam - integer(i_kind),intent( out) :: ierr integer(i_kind) i,k,ndimensions,iret,nvariables,nattributes,unlimiteddimid integer(i_kind) len,gfile_loc character(len=max_varname_length) :: name @@ -547,18 +550,17 @@ subroutine gsi_rfv3io_get_ens_grid_specs(grid_spec,ierr) use netcdf, only: nf90_inquire_variable use mpimod, only: mype use mod_fv3_lola, only: definecoef_regular_grids - use gridmod, only:nsig,regional_time,regional_fhr,regional_fmin,aeta1_ll,aeta2_ll use gridmod, only:nlon_regionalens,nlat_regionalens use gridmod, only:grid_type_fv3_regional use kinds, only: i_kind,r_kind use constants, only: half,zero use mpimod, only: mpi_comm_world,mpi_itype,mpi_rtype implicit none - character(:),allocatable,intent(in) :: grid_spec + character(:),allocatable,intent(in ) :: grid_spec + integer(i_kind), intent( out) :: ierr integer(i_kind) gfile_grid_spec - integer(i_kind),intent( out) :: ierr - integer(i_kind) i,k,ndimensions,iret,nvariables,nattributes,unlimiteddimid + integer(i_kind) k,ndimensions,iret,nvariables,nattributes,unlimiteddimid integer(i_kind) gfile_loc,len character(len=128) :: name integer(i_kind) :: nio,nylen @@ -975,6 +977,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) implicit none type (type_fv3regfilenameg),intent (in) :: fv3filenamegin(:) + integer(i_kind) :: it character(len=24),parameter :: myname = 'read_fv3_netcdf_guess' integer(i_kind) k,i,j @@ -2016,12 +2019,13 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) implicit none - integer(i_kind),intent(in) :: it - real(r_kind),intent(in),dimension(:,:),pointer::ges_z - real(r_kind),intent(in),dimension(:,:),pointer::ges_t2m - real(r_kind),intent(in),dimension(:,:),pointer::ges_q2m - real(r_kind),intent(in),dimension(:,:),pointer::ges_howv + integer(i_kind), intent(in) :: it + real(r_kind), intent(in),dimension(:,:),pointer::ges_z + real(r_kind), intent(in),dimension(:,:),pointer::ges_t2m + real(r_kind), intent(in),dimension(:,:),pointer::ges_q2m + real(r_kind), intent(in),dimension(:,:),pointer::ges_howv type (type_fv3regfilenameg),intent(in) :: fv3filenamegin + character(len=max_varname_length) :: name integer(i_kind),allocatable,dimension(:):: dim real(r_kind),allocatable,dimension(:):: work @@ -2329,8 +2333,8 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io) use general_commvars_mod, only: ltosi_s,ltosj_s implicit none - character(*) ,intent(in ) :: varname,varname2,filenamein - real(r_kind) ,intent(out ) :: work_sub(lat2,lon2) + character(*) , intent(in ) :: varname,varname2,filenamein + real(r_kind) , intent(out ) :: work_sub(lat2,lon2) integer(i_kind) ,intent(in ) :: mype_io real(r_kind),allocatable,dimension(:,:,:):: uu real(r_kind),allocatable,dimension(:):: work @@ -2429,11 +2433,12 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none - type(sub2grid_info), intent(in):: grd_ionouv - type(gsi_bundle),intent(inout) :: cstate_nouv - character(*),intent(in):: filenamein - type (type_fv3regfilenameg),intent(in) ::fv3filenamegin - logical, intent(in ) :: ensgrid + type(sub2grid_info), intent(in ) :: grd_ionouv + type(gsi_bundle), intent(inout) :: cstate_nouv + character(*), intent(in ) :: filenamein + type (type_fv3regfilenameg),intent(in ) ::fv3filenamegin + logical, intent(in ) :: ensgrid + real(r_kind),allocatable,dimension(:,:):: uu2d real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork character(len=max_varname_length) :: varname,vgsiname @@ -2450,7 +2455,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens integer(i_kind) nz,nzp1,mm1,nx_phy integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror - integer(i_kind),dimension(npe):: members,members_read,mype_read,mype_read_rank + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank logical:: procuse ! for io_layout > 1 @@ -2653,11 +2658,12 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none - type(sub2grid_info), intent(in):: grd_ionouv - character(*),intent(in):: filenamein - logical, intent(in ) :: ensgrid - type (type_fv3regfilenameg) :: fv3filenamegin - type(gsi_bundle),intent(inout) :: cstate_nouv + type(sub2grid_info), intent(in):: grd_ionouv + character(*), intent(in):: filenamein + logical, intent(in ) :: ensgrid + type (type_fv3regfilenameg), intent(in) :: fv3filenamegin + type(gsi_bundle), intent(inout) :: cstate_nouv + real(r_kind),allocatable,dimension(:,:):: uu2d real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork character(len=max_filename_length) :: filenamein2 @@ -2762,11 +2768,12 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none - type(sub2grid_info), intent(in):: grd_uv + type(sub2grid_info), intent(in):: grd_uv real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_u real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_v type (type_fv3regfilenameg),intent (in) :: fv3filenamegin - logical, intent(in ) :: ensgrid + logical, intent(in ) :: ensgrid + real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork character(:), allocatable:: filenamein real(r_kind),allocatable,dimension(:,:):: u2d,v2d @@ -2785,7 +2792,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) integer(i_kind) nz,nzp1,mm1 integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror - integer(i_kind),dimension(npe):: members,members_read,mype_read,mype_read_rank + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank logical:: procuse ! for fv3_io_layout_y > 1 @@ -2997,11 +3004,12 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none - type(sub2grid_info), intent(in):: grd_uv - real(r_kind) ,intent(out ) :: ges_u(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig) - real(r_kind) ,intent(out ) :: ges_v(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig) + type(sub2grid_info), intent(in):: grd_uv + real(r_kind) , intent(out ) :: ges_u(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig) + real(r_kind) , intent(out ) :: ges_v(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig) type (type_fv3regfilenameg),intent (in) :: fv3filenamegin - logical, intent(in ) :: ensgrid + logical, intent(in ) :: ensgrid + real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork character(len=:),allocatable :: filenamein real(r_kind),allocatable,dimension(:,:):: us2d,vw2d @@ -3137,12 +3145,12 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none - character(*),intent(in):: filenamein - type (type_fv3regfilenameg),intent(in) ::fv3filenamegin - integer(i_kind) ,intent(in ) :: iope + character(*), intent(in) :: filenamein + type (type_fv3regfilenameg), intent(in) ::fv3filenamegin + integer(i_kind) , intent(in) :: iope + real(r_kind),dimension(nlat,nlon,nsig),intent(out),optional:: delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz,fed real(r_kind),allocatable,dimension(:,:):: uu2d, uu2d_tmp 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,fed character(len=max_varname_length) :: varname character(len=max_varname_length) :: name character(len=max_filename_length), allocatable,dimension(:) :: varname_files @@ -3367,7 +3375,8 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i real(r_kind) ,intent(out ) :: ges_u(nlat,nlon,nsig) real(r_kind) ,intent(out ) :: ges_v(nlat,nlon,nsig) type (type_fv3regfilenameg),intent (in) :: fv3filenamegin - integer(i_kind), intent(in) :: iope + integer(i_kind),intent(in) :: iope + real(r_kind),dimension(2,nlat,nlon,nsig):: hwork character(:), allocatable:: filenamein real(r_kind),allocatable,dimension(:,:):: u2d,v2d @@ -3938,13 +3947,13 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) implicit none type(sub2grid_info), intent(in):: grd_uv - real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork - logical ,intent(in ) :: add_saved + logical, intent(in ) :: add_saved type (type_fv3regfilenameg),intent(in) ::fv3filenamegin real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_u real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_v + real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork integer(i_kind) :: ugrd_VarId,gfile_loc,vgrd_VarId integer(i_kind) i,j,mm1,k,nzp1 integer(i_kind) kbgn,kend @@ -3960,7 +3969,7 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) real(r_kind),allocatable,dimension(:,:):: workbu2,workbv2 integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,ierror - integer(i_kind),dimension(npe):: members,members_read,mype_read,mype_read_rank + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank logical:: procuse ! for fv3_io_layout_y > 1 @@ -4169,11 +4178,12 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) use netcdf, only: nf90_put_var,nf90_get_var use general_sub2grid_mod, only: sub2grid_info,general_sub2grid implicit none - type(sub2grid_info), intent(in):: grd_uv + type(sub2grid_info), intent(in) :: grd_uv real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_u real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_v - logical ,intent(in ) :: add_saved - type (type_fv3regfilenameg),intent (in) :: fv3filenamegin + logical, intent(in) :: add_saved + type (type_fv3regfilenameg),intent(in) :: fv3filenamegin + real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork character(len=:),allocatable :: filenamein character(len=max_varname_length) :: varname @@ -4513,12 +4523,13 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_sub2grid implicit none - type(sub2grid_info), intent(in):: grd_ionouv - type(gsi_bundle),intent(inout) :: cstate_nouv - logical ,intent(in ) :: add_saved - character(len=:), allocatable, intent(in) :: filenamein - type (type_fv3regfilenameg),intent (in) :: fv3filenamegin + type(sub2grid_info), intent(in) :: grd_ionouv + type(gsi_bundle), intent(inout):: cstate_nouv + logical, intent(in ):: add_saved + character(len=:), allocatable, intent(in) :: filenamein + type (type_fv3regfilenameg), intent(in) :: fv3filenamegin + real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork character(len=max_filename_length) :: filenamein2 character(len=max_varname_length) :: varname,vgsiname,name @@ -4536,7 +4547,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file real(r_kind),allocatable,dimension(:,:):: work_b_tmp integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror - integer(i_kind),dimension(npe):: members,members_read,mype_read,mype_read_rank + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank logical:: procuse ! for io_layout > 1 @@ -4770,11 +4781,12 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f use general_sub2grid_mod, only: sub2grid_info,general_sub2grid implicit none - type(sub2grid_info), intent(in):: grd_ionouv - type(gsi_bundle),intent(inout) :: cstate_nouv - logical ,intent(in ) :: add_saved - character(*),intent(in):: filenamein - type (type_fv3regfilenameg),intent (in) :: fv3filenamegin + type(sub2grid_info), intent(in) :: grd_ionouv + type(gsi_bundle), intent(inout):: cstate_nouv + logical, intent(in ):: add_saved + character(*), intent(in) :: filenamein + type (type_fv3regfilenameg),intent(in) :: fv3filenamegin + real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork character(len=max_filename_length) :: filenamein2 @@ -4863,6 +4875,7 @@ subroutine reverse_grid_r(grid,nx,ny,nz) implicit none integer(i_kind), intent(in ) :: nx,ny,nz real(r_kind), intent(inout ) :: grid(nx,ny,nz) + real(r_kind) :: tmp_grid(nx,ny) integer(i_kind) :: i,j,k ! @@ -4886,6 +4899,7 @@ subroutine reverse_grid_r_uv(grid,nx,ny,nz) implicit none integer(i_kind), intent(in ) :: nx,ny,nz real(r_kind), intent(inout ) :: grid(nx,ny,nz) + real(r_kind) :: tmp_grid(nx,ny) integer(i_kind) :: i,j,k ! @@ -5302,13 +5316,13 @@ subroutine convert_cvpnx_to_nx(qnx_arr,cvpnr,cvpnr_pvalue,cloud_nt_updt,q_arr,qr implicit none - real(r_kind), intent(inout ) :: qnx_arr(lat2,lon2,nsig) - logical, intent(in ) :: cvpnr - real(r_kind), intent(in ) :: cvpnr_pvalue - integer(i_kind), intent(in ) :: cloud_nt_updt - real(r_kind), intent(in ) :: q_arr(lat2,lon2,nsig) - real(r_kind), intent(in ) :: qr_arr(lat2,lon2,nsig) - real(r_kind), intent(in ) :: ps_arr(lat2,lon2) + real(r_kind), intent(inout) :: qnx_arr(lat2,lon2,nsig) + logical, intent(in ) :: cvpnr + real(r_kind), intent(in ) :: cvpnr_pvalue + integer(i_kind), intent(in ) :: cloud_nt_updt + real(r_kind), intent(in ) :: q_arr(lat2,lon2,nsig) + real(r_kind), intent(in ) :: qr_arr(lat2,lon2,nsig) + real(r_kind), intent(in ) :: ps_arr(lat2,lon2) real(r_kind), dimension(lat2,lon2,nsig) :: tmparr_qnr integer(i_kind) :: i, j, k, it @@ -5372,10 +5386,10 @@ subroutine gsi_copy_bundle(bundi,bundo) ! !INPUT PARAMETERS: type(gsi_bundle), intent(in ) :: bundi + type(gsi_bundle), intent(inout) :: bundo ! !INPUT/OUTPUT PARAMETERS: - type(gsi_bundle), intent(inout) :: bundo character(len=max_varname_length),dimension(:),allocatable:: src_name_vars2d character(len=max_varname_length),dimension(:),allocatable:: src_name_vars3d character(len=max_varname_length),dimension(:),allocatable:: target_name_vars2d @@ -5420,10 +5434,12 @@ subroutine gsi_copy_bundle(bundi,bundo) return end subroutine gsi_copy_bundle subroutine getfv3lamfilevname(vgsinamein,fv3filenamegref,filenameout,vname) + type (type_fv3regfilenameg),intent (in) :: fv3filenamegref - character(len=*):: vgsinamein character(len=*),intent(out):: vname character(len=*),intent(out):: filenameout + character(len=*),intent( in):: vgsinamein + if (ifindstrloc(vgsiname,vgsinamein)<= 0) then write(6,*)'the name ',vgsinamein ,'cannot be treated correctly in getfv3lamfilevname,stop' call stop2(333) diff --git a/src/gsi/gsisub.F90 b/src/gsi/gsisub.F90 index 6aef101f55..94489266ba 100644 --- a/src/gsi/gsisub.F90 +++ b/src/gsi/gsisub.F90 @@ -194,7 +194,7 @@ subroutine gsisub(init_pass,last_pass) end if if(last_pass) call observer_finalize() #ifndef HAVE_ESMF - call destroy_gesfinfo() ! paired with gesinfo() + call destroy_gesfinfo() ! paired with gesinfo() #endif else call glbsoi diff --git a/src/gsi/hdraobmod.f90 b/src/gsi/hdraobmod.f90 index c56b400909..3444c96fcc 100644 --- a/src/gsi/hdraobmod.f90 +++ b/src/gsi/hdraobmod.f90 @@ -188,7 +188,7 @@ subroutine read_hdraob(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& real(r_kind),dimension(nsig):: presl,hgtl real(r_kind),dimension(nsig-1):: dpres real(r_kind),dimension(maxlevs)::plevs - real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out + real(r_kind),allocatable,dimension(:,:):: cdata_all real(r_kind) :: missing real(r_double) rstation_id,r_station @@ -1271,20 +1271,13 @@ subroutine read_hdraob(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& close(lunin) ! Write header record and data to output file for further processing - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - do k=1,nreal - cdata_out(k,i)=cdata_all(k,i) - end do - end do - deallocate(cdata_all) - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata - write(lunout) cdata_out + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) - deallocate(cdata_out) + deallocate(cdata_all) if(diagnostic_reg .and. ntest>0) write(6,*)'READ_HDRAOB: ',& 'ntest,disterrmax=',ntest,disterrmax diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index ef6b53119c..05b3845627 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -1882,8 +1882,8 @@ subroutine ensemble_forward_model(cvec,a_en,ibin) iaens=ensgrp2aensgrp(ig,ic2+nc3d,ibin) if(iaens>0) then do n=1,n_ens - do j=1,jm - do k=1,km_tmp + do k=1,km_tmp + do j=1,jm do i=1,im cvec%r2(ipic)%q(i,j)=cvec%r2(ipic)%q(i,j) & +a_en(iaens,n)%r3(ipx)%q(i,j,k)*en_perts(n,ig,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) @@ -4083,8 +4083,8 @@ subroutine hybens_grid_setup region_lat_ens=region_lat end if end if - if(mype==0) write(6,*)' dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps=',& - dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps + if(mype==0) write(6,*)' dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps=',& + dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps if(nlon_ens<=0 .or. nlat_ens<=0) then nlon_ens=nlon ; nlat_ens=nlat @@ -4216,8 +4216,7 @@ subroutine hybens_localization_setup real(r_kind),allocatable:: s_ens_h_gu_x(:,:),s_ens_h_gu_y(:,:) logical :: l_read_success type(gsi_bundle) :: a_en(n_ens) - type(gsi_bundle) :: en_pertstmp(n_ens,ntlevs_ens) - type(gsi_bundle) :: en_pertstmp1(n_ens,ntlevs_ens) + type(gsi_bundle),allocatable :: en_pertstmp(:,:),en_pertstmp1(:,:) type(gsi_grid) :: grid_ens real(r_kind), pointer :: values(:) => NULL() integer(i_kind) :: iscl, iv, smooth_scales_num @@ -4281,10 +4280,9 @@ subroutine hybens_localization_setup vvlocal = .true. nz = msig kl = grd_loc%kend_alloc-grd_loc%kbegin_loc+1 - if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens,naensloc)) - if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens,naensloc)) endif + endif ! if ( readin_localization .or. readin_beta ) 100 format(I4) @@ -4312,8 +4310,6 @@ subroutine hybens_localization_setup if ( .not. readin_localization ) then ! assign all levels to same value, s_ens_h, s_ens_v nz = 1 kl = 1 - if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(1,naensloc)) - if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(1,naensloc)) do ig=1,naensloc s_ens_hv(:,ig) = s_ens_h(ig) s_ens_vv(:,ig) = s_ens_v(ig) @@ -4327,6 +4323,8 @@ subroutine hybens_localization_setup if ( regional ) then ! convert s_ens_h from km to grid units. if ( vvlocal ) then + allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens,naensloc)) + allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens,naensloc)) call convert_km_to_grid_units(s_ens_h_gu_x(1:nz,:),s_ens_h_gu_y(1:nz,:),nz) do n=2,n_ens nk=(n-1)*nz @@ -4338,12 +4336,16 @@ subroutine hybens_localization_setup call init_rf_x(s_ens_h_gu_x(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl) call init_rf_y(s_ens_h_gu_y(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl) else + allocate(s_ens_h_gu_x(1,naensloc)) + allocate(s_ens_h_gu_y(1,naensloc)) call convert_km_to_grid_units(s_ens_h_gu_x,s_ens_h_gu_y,nz) call init_rf_x(s_ens_h_gu_x,kl) call init_rf_y(s_ens_h_gu_y,kl) endif call normal_new_factorization_rf_x call normal_new_factorization_rf_y + deallocate(s_ens_h_gu_x) + deallocate(s_ens_h_gu_y) else call init_sf_xy(jcap_ens) endif @@ -4415,6 +4417,8 @@ subroutine hybens_localization_setup else ! assign_vdl_nml smooth_scales_num = naensloc - naensgrp ngvarloc = 1 ! forced to 1 in this option + allocate(en_pertstmp(n_ens,ntlevs_ens)) + allocate(en_pertstmp1(n_ens,ntlevs_ens)) do n = 1, n_ens do m = 1, ntlevs_ens call gsi_bundlecreate(en_pertstmp(n,m),grid_ens,'ensemble2',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_single) @@ -4505,6 +4509,7 @@ subroutine hybens_localization_setup call gsi_bundledestroy(en_pertstmp1(n,m),istatus) end do end do + deallocate(en_pertstmp,en_pertstmp1) end if deallocate(values) endif @@ -5445,6 +5450,7 @@ subroutine acceptable_for_essl_fft(nin,nout) nout=n_acceptable_table(i) if(nout.ge.nin) exit enddo + deallocate(n_acceptable_table) return end subroutine acceptable_for_essl_fft diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 index 342dead615..23065ebb5b 100644 --- a/src/gsi/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -428,6 +428,7 @@ module hybrid_ensemble_parameters real(r_kind),allocatable:: region_lat_ens(:,:),region_lon_ens(:,:) real(r_kind),allocatable:: region_dx_ens(:,:),region_dy_ens(:,:) + contains subroutine init_hybrid_ensemble_parameters diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90 index f36e9e4b26..4b149da6b9 100644 --- a/src/gsi/intjcmod.f90 +++ b/src/gsi/intjcmod.f90 @@ -180,34 +180,30 @@ subroutine intlimqc(rval,sval,itbin,cldtype) call gsi_bundlegetpointer(sval,'ql',sqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'ql',rqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'ql',ges_qc_it,ier1) - endif - if (trim(cldtype) == 'qi') then + else if (trim(cldtype) == 'qi') then factqc = factqi call gsi_bundlegetpointer(sval,'qi',sqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'qi',rqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qi',ges_qc_it,ier1) - endif - if (trim(cldtype) == 'qr') then + else if (trim(cldtype) == 'qr') then factqc = factqr call gsi_bundlegetpointer(sval,'qr',sqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'qr',rqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qr',ges_qc_it,ier1) - endif - if (trim(cldtype) == 'qs') then + else if (trim(cldtype) == 'qs') then factqc = factqs call gsi_bundlegetpointer(sval,'qs',sqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'qs',rqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qs',ges_qc_it,ier1) - endif - if (trim(cldtype) == 'qg') then + else if (trim(cldtype) == 'qg') then factqc = factqg call gsi_bundlegetpointer(sval,'qg',sqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'qg',rqc,istatus);ier=istatus+ier call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qg',ges_qc_it,ier1) endif - if (mype==0) write(6,*) 'intlimqc: factqc = ', factqc - if (mype==0) write(6,*) 'intlimqc: ier ier1= ', ier, ier1 if (factqc == zero) return + if (mype==0) write(6,*) 'intlimqc: factqc = ', factqc, trim(cldtype) + if (mype==0) write(6,*) 'intlimqc: ier ier1= ', ier, ier1 if (ier/=0 .or. ier1/=0) return !$omp parallel do schedule(dynamic,1) private(k,j,i,qc) diff --git a/src/gsi/intrw.f90 b/src/gsi/intrw.f90 index bac4448c0d..05b20e7991 100644 --- a/src/gsi/intrw.f90 +++ b/src/gsi/intrw.f90 @@ -127,23 +127,17 @@ subroutine intrw_(rwhead,rval,sval) ier=0 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 (if_use_w_vr.and.istatus==0) then - include_w=.true. - else - include_w=.false. - end if 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 (if_use_w_vr.and.istatus==0) then - include_w=.true. - else - include_w=.false. - end if if(ier/=0)return + include_w=.false. + call gsi_bundlegetpointer(sval,'w',sw,istatus) + if (if_use_w_vr.and.istatus==0) then + call gsi_bundlegetpointer(rval,'w',rw,istatus) + if(istatus == 0)include_w=.true. + end if !rwptr => rwhead rwptr => rwNode_typecast(rwhead) diff --git a/src/gsi/jgrad.f90 b/src/gsi/jgrad.f90 index c6e2e5415c..6b17544300 100755 --- a/src/gsi/jgrad.f90 +++ b/src/gsi/jgrad.f90 @@ -59,6 +59,7 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) use mpl_allreducemod, only: mpl_allreduce use obs_sensitivity, only: efsoi_o2_update use control2state_mod, only: control2state,control2state_ad +use ensctl2state_mod, only: ensctl2state,ensctl2state_ad implicit none diff --git a/src/gsi/m_extOzone.F90 b/src/gsi/m_extOzone.F90 index bf2b137466..5dead0551a 100644 --- a/src/gsi/m_extOzone.F90 +++ b/src/gsi/m_extOzone.F90 @@ -1481,7 +1481,7 @@ subroutine ozlay_ncread_(dfile,dtype,ozout,nmrecs,ndata,nodata, gstime,twind) use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar - use constants, only: deg2rad,zero,rad2deg,one_tenth,r60inv + use constants, only: deg2rad,zero,one_tenth,r60inv use ozinfo, only: jpch_oz,nusis_oz,iuse_oz use mpeu_util, only: perr,die ! use mpeu_util, only: mprefix,stdout diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90 index 4ec3c0cb93..e8df85068e 100644 --- a/src/gsi/mod_fv3_lola.f90 +++ b/src/gsi/mod_fv3_lola.f90 @@ -631,8 +631,7 @@ subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_l real(r_kind),allocatable,dimension(:)::xbh_a,xa_a,xa_b real(r_kind),allocatable,dimension(:)::ybh_a,ya_a,ya_b,yy real(r_kind),allocatable,dimension(:,:)::xbh_b,ybh_b - real(r_kind) dlat,dlon,dyy,dxx,dyyi,dxxi - real(r_kind) dyyh,dxxh + real(r_kind) dlat,dlon real(r_kind),allocatable:: region_lat_tmp(:,:),region_lon_tmp(:,:) integer(i_kind), intent(in ) :: nxen,nyen ! fv3 tile x- and y-dimensions @@ -642,18 +641,15 @@ subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_l real(r_kind) , intent(inout) :: grid_latt(nxen,nyen) ! fv3 cell center latitudes integer(i_kind) i,j,ir,jr,n real(r_kind),allocatable,dimension(:,:) :: xc,yc,zc,gclat,gclon,gcrlat,gcrlon,rlon_in,rlat_in - real(r_kind),allocatable,dimension(:,:) :: glon_an,glat_an real(r_kind) xcent,ycent,zcent,rnorm,centlat,centlon - integer(i_kind) nlonh,nlath,nxh,nyh + integer(i_kind) nxh,nyh integer(i_kind) ib1,ib2,jb1,jb2,jj integer (i_kind):: index0 - real(r_kind) region_lat_in(nlat_ens,nlon_ens),region_lon_in(nlat_ens,nlon_ens) integer(i_kind) nord_e2a real(r_kind)gxa,gya real(r_kind) x(nxen+1,nyen+1),y(nxen+1,nyen+1),z(nxen+1,nyen+1),xr,yr,zr,xu,yu,zu,rlat,rlon real(r_kind) xv,yv,zv,vval - real(r_kind) cx,cy real(r_kind) uval,ewval,nsval real(r_kind) d(4),ds @@ -1258,7 +1254,6 @@ subroutine fv3_h_to_ll_ens(b_in,a,nb,mb,na,ma,rev_flg) ! machine: ! !$$$ end documentation block - use mpimod, only: mype use constants, only: zero,one implicit none diff --git a/src/gsi/obs_para.f90 b/src/gsi/obs_para.f90 index 530e946be6..869efa5e78 100644 --- a/src/gsi/obs_para.f90 +++ b/src/gsi/obs_para.f90 @@ -41,11 +41,10 @@ subroutine obs_para(ndata,mype) ! grid. ! ! input argument list: -! ndata(*,1)- number of prefiles retained for further processing +! ndata(*,1)- number of profiles retained for further processing ! ndata(*,2)- number of observations read ! ndata(*,3)- number of observations keep after read ! mype - mpi task number -! ipoint - pointer in array containing information about all obs type to process ! ! output argument list: ! @@ -342,7 +341,8 @@ subroutine count_obs(ndata,nn_obs,lat_data,lon_data,obs_data,nobs_s) integer(i_kind) ,intent(in ) :: ndata,lat_data,lon_data integer(i_kind) ,intent(in ) :: nn_obs integer(i_kind),dimension(npe),intent(inout) :: nobs_s - real(r_kind),dimension(nn_obs,ndata),intent(in) :: obs_data + real(r_kind),dimension(nn_obs,*),intent(in) :: obs_data +! real(r_kind),dimension(nn_obs,ndata),intent(in) :: obs_data ! Declare local variables integer(i_kind) lon,lat,n,k diff --git a/src/gsi/obs_sensitivity.f90 b/src/gsi/obs_sensitivity.f90 index b6498d09fc..8e5a87010f 100644 --- a/src/gsi/obs_sensitivity.f90 +++ b/src/gsi/obs_sensitivity.f90 @@ -62,6 +62,7 @@ module obs_sensitivity use hybrid_ensemble_isotropic, only: hybens_localization_setup use mpeu_util, only: perr,die use control2state_mod, only: control2state,control2state_ad +use ensctl2state_mod, only: ensctl2state,ensctl2state_ad ! ------------------------------------------------------------------------------ implicit none save diff --git a/src/gsi/observer.F90 b/src/gsi/observer.F90 index 00f51448ac..52920630a4 100644 --- a/src/gsi/observer.F90 +++ b/src/gsi/observer.F90 @@ -49,8 +49,6 @@ module observermod use gsi_4dvar, only: l4dvar use convinfo, only: convinfo_destroy use m_gsiBiases, only : create_bkgbias_grids, destroy_bkgbias_grids - use m_berror_stats, only: berror_get_dims - use m_berror_stats_reg, only: berror_get_dims_reg use timermod, only: timer_ini, timer_fnl use read_obsmod, only: read_obs use lag_fields, only: lag_guessini diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 4f1a8c76bf..1c45c62bc8 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -485,8 +485,8 @@ module obsmod public :: doradaroneob,oneoblat,oneoblon public :: oneobddiff,oneobvalue,oneobheight,oneobradid - public :: ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz,rmesh_vr,zmesh_vr - public :: radar_no_thinning + public :: ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz,rmesh_vr,zmesh_vr,pmot_dbz + public :: radar_no_thinning,pmot_vr public :: mintiltvr,maxtiltvr,minobrangevr,maxobrangevr public :: mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz public :: debugmode @@ -631,7 +631,7 @@ module obsmod real(r_kind) ,allocatable,dimension(:):: dval real(r_kind) ,allocatable,dimension(:):: time_window - integer(i_kind) ntilt_radarfiles,tcp_posmatch,tcp_box + integer(i_kind) ntilt_radarfiles,tcp_posmatch,tcp_box,pmot_dbz,pmot_vr logical :: ta2tb logical :: doradaroneob,dofedoneob @@ -788,6 +788,14 @@ subroutine init_obsmod_dflts static_gsi_nopcp_dbz=0.0_r_kind rmesh_dbz=2 rmesh_vr=2 +! pmot_dbz values of 0,1,2,3 will save different sets of obs output +! pmot_dbz - all obs - thin obs +! pmot_dbz - all obs +! pmot_dbz - use obs +! pmot_dbz - use obs + thin obs + + pmot_dbz=0 + pmot_vr=2 zmesh_dbz=500.0_r_kind zmesh_vr=500.0_r_kind minobrangedbz=10000.0_r_kind diff --git a/src/gsi/pcgsoi.f90 b/src/gsi/pcgsoi.f90 index fac01c9315..0b808c5c55 100644 --- a/src/gsi/pcgsoi.f90 +++ b/src/gsi/pcgsoi.f90 @@ -266,7 +266,7 @@ subroutine pcgsoi() ! Perform inner iteration inner_iteration: do iter=0,niter(jiter) - diag_print= iter <= 1 .and. print_diag_pcg + diag_print= iter <= 1 .and. print_diag_pcg ! Gradually turn on old variational qc to avoid possible convergence problems if(vqc) then @@ -298,6 +298,7 @@ subroutine pcgsoi() enddo endif + ! Adjoint of control to state call c2s_ad(gradx,rval,rbias,llprt) @@ -637,13 +638,7 @@ subroutine pcgsoi() ! Write output analysis files if(.not.l4dvar) call prt_guess('analysis') call prt_state_norms(sval(1),'increment') - if (twodvar_regional) then - call write_all(-1) - else - if(jiter == miter) then - call write_all(-1) - endif - endif + if (twodvar_regional .or. jiter == miter) call write_all(-1) ! Overwrite guess with increment (4d-var only, for now) if (iwrtinc>0) then @@ -910,6 +905,7 @@ subroutine c2s(hat,val,bias,llprt,ltest) use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar use gsi_4dcouplermod, only : gsi_4dcoupler_grtests use control2state_mod, only: control2state,control2state_ad + use ensctl2state_mod, only: ensctl2state implicit none type(control_vector) ,intent(inout) :: hat @@ -977,6 +973,7 @@ subroutine c2s_ad(hat,val,bias,llprt) use gsi_bundlemod, only : self_add use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar use control2state_mod, only: control2state_ad + use ensctl2state_mod, only: ensctl2state_ad implicit none type(control_vector) ,intent(inout) :: hat diff --git a/src/gsi/prewgt_reg.f90 b/src/gsi/prewgt_reg.f90 index 1da89a703b..d79a06697e 100644 --- a/src/gsi/prewgt_reg.f90 +++ b/src/gsi/prewgt_reg.f90 @@ -164,7 +164,6 @@ subroutine prewgt_reg(mype) real(r_kind),allocatable,dimension(:,:,:,:)::sli real(r_quad),dimension(180,nsig):: ozmz,cnt real(r_quad),dimension(180*nsig):: ozmz0,cnt0 - real(r_kind),dimension(180,nsig):: ozmzt,cntt real(r_kind),dimension(:,:,:),pointer::ges_oz=>NULL() @@ -267,13 +266,13 @@ subroutine prewgt_reg(mype) do k=1,nsig do ix=1,180 i=i+1 - ozmzt(ix,k)=ozmz0(i) - cntt(ix,k)=cnt0(i) + ozmz(ix,k)=ozmz0(i) + cnt(ix,k)=cnt0(i) end do end do do k=1,nsig do i=1,180 - if(cntt(i,k)>zero) ozmzt(i,k)=sqrt(ozmzt(i,k)/cntt(i,k)) + if(cnt(i,k)>zero) ozmz(i,k)=sqrt(ozmz(i,k)/cnt(i,k)) enddo enddo endif ! regional_ozone @@ -455,7 +454,7 @@ subroutine prewgt_reg(mype) dl2=d-real(l,r_kind) dl1=one-dl2 do k=1,nsig - dssv(i,j,k,n)=(dl1*ozmzt(l,k)+dl2*ozmzt(l2,k))*dsv(1,k,llmin) + dssv(i,j,k,n)=(dl1*ozmz(l,k)+dl2*ozmz(l2,k))*dsv(1,k,llmin) end do end do end do diff --git a/src/gsi/read_NASA_LaRC_cloud.f90 b/src/gsi/read_NASA_LaRC_cloud.f90 index ec3f29e3fa..05889e2d6b 100644 --- a/src/gsi/read_NASA_LaRC_cloud.f90 +++ b/src/gsi/read_NASA_LaRC_cloud.f90 @@ -172,6 +172,13 @@ subroutine read_NASA_LaRC_cloud(nread,ndata,nouse,infile,obstype,lunout,sis,nob write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,numobs) write(6,*)'NASA larcglb::',nreal,numobs + deallocate(cdata_all) + deallocate(lat_l) + deallocate(lon_l) + deallocate(ptop_l) + deallocate(teff_l) + deallocate(phase_l) + deallocate(lwp_l) return end subroutine read_NASA_LaRC_cloud diff --git a/src/gsi/read_aerosol.f90 b/src/gsi/read_aerosol.f90 index 0d07a6c904..a58b2d4358 100644 --- a/src/gsi/read_aerosol.f90 +++ b/src/gsi/read_aerosol.f90 @@ -367,7 +367,7 @@ subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, & end if ! Deallocate local arrays - deallocate(aeroout) + deallocate(aeroout,nrec) deallocate(dataaod) ! End of MODIS bufr block @@ -596,7 +596,8 @@ subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, & end if ! Deallocate local arrays - deallocate(aeroout) + deallocate(aeroout,nrec) + deallocate(dataaod) ! End of VIIRS AOD bufr block diff --git a/src/gsi/read_avhrr.f90 b/src/gsi/read_avhrr.f90 index 48c6200c44..c1509828ad 100755 --- a/src/gsi/read_avhrr.f90 +++ b/src/gsi/read_avhrr.f90 @@ -585,6 +585,7 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,& deallocate(data_mesh,nrec) enddo ! do imesh = 1, nmesh + deallocate(amesh,hsst_thd) ! Allow single task to check for bad obs, update superobs sum, ! and write out data to scratch file for further processing. diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index f4bf288c9a..f06545afa1 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -73,12 +73,12 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no use gridmod, only: tll2xy,nsig,nlat,nlon use obsmod, only: iadate,doradaroneob,oneoblat,oneoblon,oneobheight, & mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz,& - static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz + static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz,pmot_dbz,reduce_diag use gsi_4dvar, only: iwinbgn use hybrid_ensemble_parameters,only : l_hyb_ens use obsmod,only: radar_no_thinning,missing_to_nopcp use convinfo, only: nconvtype,ctwind,icuse,ioctype - use convthin, only: make3grids,map3grids,del3grids,use_all + use convthin, only: make3grids,map3grids_m,del3grids,use_all use jfunc, only: miter use mpimod, only: npe implicit none @@ -134,17 +134,14 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no real(r_kind), allocatable, dimension(:) :: zl_thin real(r_kind),dimension(nsig):: hges,zges real(r_kind) sin2,termg,termr,termrg,zobs,hgt - integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2 + integer(i_kind) iout,ntdrvr_thin2 real(r_kind) crit1,timedif real(r_kind),parameter:: r16000 = 16000.0_r_kind logical :: luse - integer(i_kind) maxout,maxdata - integer(i_kind),allocatable,dimension(:):: isort !--General declarations - integer(i_kind) :: ierror,i,j,k,nvol, & - ikx,mins_an + integer(i_kind) :: ierror,i,j,k,ikx,mins_an integer(i_kind) :: maxobs,nchanl,ilat,ilon,scount real(r_kind) :: thistiltr,thisrange,this_stahgt,thishgt @@ -152,9 +149,13 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no dlat,dlon,thiserr,thislon,thislat, & timeb real(r_kind) :: radartwindow - real(r_kind) :: rmins_an + real(r_kind) :: rmins_an,usage real(r_kind),allocatable,dimension(:,:):: cdata_all real(r_double) rstation_id + logical, allocatable,dimension(:) :: rusage,rthin + logical save_all +! integer(i_kind) numthin,numqc,numrem,numall + integer(i_kind) nxdata,pmot character(8) cstaid character(4) this_staid @@ -218,19 +219,15 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no maxobs=50000000 !value taken from read_radar.f90 !--Allocate cdata_all array - allocate(cdata_all(maxdat,maxobs),isort(maxobs)) - rmesh=rmesh_dbz - zmesh=zmesh_dbz + allocate(cdata_all(maxdat,maxobs),rthin(maxobs),rusage(maxobs)) + rmesh=rmesh_dbz + zmesh=zmesh_dbz + ntdrvr_thin2=0 + icntpnt=0 + zflag=0 - maxout=0 - maxdata=0 - isort=0 - ntdrvr_thin2=0 - icntpnt=0 - zflag=0 - - use_all=.true. + use_all=.true. if (ithin > 0) then write(6,*)'READ_RADAR_DBZ: ithin,rmesh :',ithin,rmesh use_all=.false. @@ -241,7 +238,6 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no endif xmesh=rmesh call make3grids(xmesh,nlevz) -! call make3grids2(xmesh,nlevz) allocate(zl_thin(nlevz)) if (zflag == 1) then @@ -304,6 +300,8 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no dbzQC = data_r_3d + deallocate(data_r_3d) + else if( ivar == 2 )then allocate( data_r_1d(dims(ivar,1)) ) @@ -341,12 +339,19 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no timeb=real(mins_an-iwinbgn,r_kind) !assume all observations are at the analysis time ivar = 1 - + pmot=pmot_dbz + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. + rusage = .true. + rthin = .false. + ILOOP : & do i = 1, dims(ivar,1) do j = 1, dims(ivar,2) do k = 1, dims(ivar,3) + imissing2nopcp = 0 ! Missing data in the input file have the value -999.0 if( dbzQC(i,j,k) <= -900.0_r_kind ) then @@ -423,10 +428,13 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no nread = nread + 1 + usage=zero + if(icuse(ikx) < zero)usage=r100 !#################### Data thinning ################### icntpnt=icntpnt+1 if(icntpnt>maxobs) exit + if(ithin > 0)then if(zflag == 0)then @@ -460,32 +468,21 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no zobs = hgt - ntmp=ndata ! counting moved to map3gridS timedif=zero ! assume all observations are at the analysis time crit1 = timedif/r6+half - call map3grids(1,zflag,zl_thin,nlevz,thislat,thislon,& - zobs,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) - - - maxout=max(maxout,iout) - maxdata=max(maxdata,ndata) - + call map3grids_m(1,save_all,zflag,zl_thin,nlevz, & + thislat,thislon,zobs,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) + if (.not. luse) then ntdrvr_thin2=ntdrvr_thin2+1 cycle endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(icntpnt)=iout else ndata =ndata+1 - nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout endif + iout=ndata !!end modified for thinning @@ -518,13 +515,57 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no cdata_all(17,iout)= dbznoise ! noise threshold for reflectivity (dBZ) cdata_all(18,iout)= imissing2nopcp !=0, normal !=1, !values !converted !from !missing !values - + if(usage >= r100)rusage(ndata)=.false. + if(doradaroneob .and. (cdata_all(5,iout) > -99.0_r_kind) ) exit ILOOP end do ! k end do ! j end do ILOOP ! i + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,ndata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' dbz ',numall,numrem,numqc,numthin + +! If flag to not save thinned data is set - compress data + if(pmot /= 1)then + do i=1,nxdata +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + if(i > ndata)then + do k=1,maxdat + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end if + end do + end if + end if + + nodata=nodata+nxdata + + deallocate(dbzQC,lat,lon) + if (.not. use_all) then deallocate(zl_thin) call del3grids @@ -550,10 +591,10 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no !---------------DEALLOCATE ARRAYS-------------! - deallocate(cdata_all) else !fileopen write(6,*) 'READ_dBZ: ERROR OPENING RADAR REFLECTIVITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...' end if fileopen +deallocate(cdata_all,rusage,rthin) end subroutine read_dbz_nc diff --git a/src/gsi/read_dbz_netcdf.f90 b/src/gsi/read_dbz_netcdf.f90 index 845660168a..193449b460 100644 --- a/src/gsi/read_dbz_netcdf.f90 +++ b/src/gsi/read_dbz_netcdf.f90 @@ -223,9 +223,7 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob real(r_single), allocatable :: azimuth_nc(:),beamwidth_nc(:),azimspacing_nc(:),gatewidth_nc(:) -real(r_single), allocatable :: nyquist_nc(:),obdata_nc(:,:) -real(r_single) nyquist_default_nc -parameter(nyquist_default_nc=50.0_r_kind) +real(r_single), allocatable :: obdata_nc(:,:) !clg ! ! due to representativeness error associated with the model !----------------------------------------------! @@ -327,7 +325,7 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob !reverse order of dimensions as stated in ncdump: allocate(azimuth_nc(numazim_nc),beamwidth_nc(numazim_nc),azimspacing_nc(numazim_nc),gatewidth_nc(numazim_nc)) -allocate(nyquist_nc(numazim_nc),obdata_nc(numgate_nc,numazim_nc)) +allocate(obdata_nc(numgate_nc,numazim_nc)) ierr = NF90_GET_VAR(ncid,varid1,azimuth_nc) if (ierr /= nf90_noerr) call handle_err(ierr,"azimuth data") @@ -607,18 +605,20 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob !---------------DEALLOCATE ARRAYS-------------! - deallocate(cdata_all) - do v=1,nvol - do k=1,nelv - deallocate(strct_in_dbz(v,k)%azim) - deallocate(strct_in_dbz(v,k)%field) - end do - end do - deallocate(strct_in_dbz) else !fileopen write(6,*) 'READ_dBZ: ERROR OPENING RADAR REFLECTIVITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...' end if fileopen + deallocate(cdata_all) + do v=1,nvol + do k=1,nelv + deallocate(strct_in_dbz(v,k)%azim) + deallocate(strct_in_dbz(v,k)%field) + end do + end do + deallocate(strct_in_dbz) + deallocate(obdata_nc,azimuth_nc) + deallocate(beamwidth_nc,azimspacing_nc,gatewidth_nc) end subroutine read_dbz_mrms_netcdf @@ -850,9 +850,7 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout, real(r_single), allocatable :: azimuth_nc(:),beamwidth_nc(:),azimspacing_nc(:),gatewidth_nc(:) -real(r_single), allocatable :: nyquist_nc(:),obdata_nc(:,:),obdata_pixel_nc(:) -real(r_single) nyquist_default_nc -parameter(nyquist_default_nc=50.0_r_kind) +real(r_single), allocatable :: obdata_pixel_nc(:) logical l_pixel_unlimited integer(i_kind):: ipix integer(i_kind)::real_numpixel,start_nc(1),count_nc(1) @@ -961,7 +959,6 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout, !reverse order of dimensions as stated in ncdump: allocate(azimuth_nc(numazim_nc),beamwidth_nc(numazim_nc),azimspacing_nc(numazim_nc),gatewidth_nc(numazim_nc)) -allocate(nyquist_nc(numazim_nc),obdata_nc(numgate_nc,numazim_nc)) allocate(obdata_pixel_nc(num_pixel_nc)) allocate(pixel_x_nc(num_pixel_nc)) allocate(pixel_y_nc(num_pixel_nc)) @@ -1263,6 +1260,9 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout, end do end do deallocate(strct_in_dbz) + deallocate(azimuth_nc,beamwidth_nc,azimspacing_nc,gatewidth_nc) + deallocate(pixel_x_nc) + deallocate(pixel_y_nc) else !fileopen write(6,*) 'READ_dBZ: ERROR OPENING RADAR REFLECTIVITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...' diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index 3d3d098b08..9ba799e341 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -36,7 +36,7 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) ! use kinds, only: r_kind,r_double,i_kind use constants, only: zero,one,deg2rad,r60inv - use convinfo, only: nconvtype,ctwind,icuse,ioctype + use convinfo, only: nconvtype,icuse,ioctype use gsi_4dvar, only: iwinbgn use gridmod, only: tll2xy use mod_wrfmass_to_a, only: wrfmass_obs_to_a8 @@ -83,15 +83,14 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) integer(i_kind) :: kint_maxloc real(r_kind) :: fed_max integer(i_kind) :: ndata2 - integer(i_kind) :: ppp character(8) station_id real(r_double) :: rstation_id equivalence(rstation_id,station_id) integer(i_kind) :: maxlvl - integer(i_kind) :: numlvl,numfed,nmsgmax,maxobs - integer(i_kind) :: k,iret + integer(i_kind) :: numfed,maxobs + integer(i_kind) :: k real(r_kind),allocatable,dimension(:,:) :: fed3d_column ! 3D fed in column real(r_kind),allocatable,dimension(:) :: fed3d_hgt ! fed height diff --git a/src/gsi/read_fl_hdob.f90 b/src/gsi/read_fl_hdob.f90 index c7dc95f612..1ef3d8617f 100644 --- a/src/gsi/read_fl_hdob.f90 +++ b/src/gsi/read_fl_hdob.f90 @@ -54,9 +54,9 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si rlats,rlons,twodvar_regional,fv3_regional use convinfo, only: nconvtype, & icuse,ictype,icsubtype,ioctype, & - ithin_conv,rmesh_conv,pmesh_conv + ithin_conv,rmesh_conv,pmesh_conv,pmot_conv use obsmod, only: perturb_obs,perturb_fact,ran01dom - use obsmod, only: bmiss + use obsmod, only: bmiss,reduce_diag use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof,aircraft_t_bc_ext use converr,only: etabl use converr_ps,only: etabl_ps,isuble_ps,maxsub_ps @@ -69,7 +69,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si use convb_uv,only: btabl_uv use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,time_4dvar,winlen,thin4d use qcmod, only: errormod,njqc - use convthin, only: make3grids,map3grids,del3grids,use_all + use convthin, only: make3grids,map3grids_m,del3grids,use_all use ndfdgrids,only: init_ndfdgrid,destroy_ndfdgrid,relocsfcob,adjust_error use deter_sfc_mod, only: deter_sfc_type,deter_sfc2 use mpimod, only: npe @@ -128,7 +128,6 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si ! integer(i_kind) :: m,itypex,lcount,iflag integer(i_kind) :: nlevp ! vertical level for thinning integer(i_kind) :: pflag - integer(i_kind) :: ntmp,iiout,igood integer(i_kind) :: kk,klon1,klat1,klonp1,klatp1 integer(i_kind) :: iuse integer(i_kind) :: nmind @@ -137,7 +136,11 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si integer(i_kind) :: ibit(mxib) integer(i_kind) :: idate5(5) - integer(i_kind), allocatable,dimension(:) :: isort + logical, allocatable,dimension(:) :: rusage,rthin + logical save_all +! integer(i_kind) numthin,numqc,numrem,numall + integer(i_kind) pmot,iqm + integer(i_kind) nxdata ! Real variables real(r_kind), parameter :: r0_001 = 0.001_r_kind @@ -171,7 +174,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si real(r_kind) :: es,qsat,rhob_calc,tdob_calc,tdry real(r_kind) :: dummy real(r_kind) :: del,ediff,errmin,jbmin - real(r_kind) :: tvflg + real(r_kind) :: tvflg,log100 real(r_kind) :: presl(nsig) real(r_kind) :: obstime(6,1) @@ -188,7 +191,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si real(r_double) :: rstation_id real(r_double) :: r_prvstg(1,1),r_sprvstg(1,1) - real(r_kind), allocatable,dimension(:,:) :: cdata_all,cdata_out + real(r_kind), allocatable,dimension(:,:) :: cdata_all real(r_kind), allocatable,dimension(:) :: presl_thin ! Equivalence to handle character names @@ -234,6 +237,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si ierr_uv = 0 var_jb=zero jbmin=zero + log100=log(100._r_kind) lim_qm = 4 @@ -258,7 +262,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si else if (lpsob) then nreal = 23 iecol = 5 - errmin = one_tenth ! set lower bound of ob error for moisture (RH) + errmin = one_tenth ! set lower bound of ob error for surface pressure else write(6,*) ' illegal obs type in read_fl_hdob ' call stop2(94) @@ -352,6 +356,11 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si write(6,*)'READ_FL_HDOB: ictype(nc),rmesh,pflag,nlevp,pmesh,nc ',& ioctype(nc),ictype(nc),rmesh,pflag,nlevp,pmesh,nc endif + pmot=nint(pmot_conv(nc)) + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. + !------------------------------------------------------------------------------------------------ @@ -377,25 +386,25 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si !--------------------------------------------------------------------------------------------------- ! Allocate array to hold data - allocate(cdata_all(nreal,maxobs)) - allocate(isort(maxobs)) + allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs)) ! Initialize cdata_all = zero - isort = 0 nread = 0 nchanl = 0 ntest = 0 nvtest = 0 ilon = 2 ilat = 3 + rusage = .true. + rthin = .false. + use_all=.true. ! Open bufr file again for reading open(lunin,file=trim(infile),form='unformatted') call openbf(lunin,'IN',lunin) call datelen(10) ntb = 0 - igood = 0 ! Loop through BUFR file loop_msg2: do while(ireadmg(lunin,subset,idate) >= 0) loop_readsb2: do while(ireadsb(lunin) == 0) @@ -603,6 +612,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si obserr = max(obserr,errmin) endif ! Read extrapolated surface pressure [pa] and convert to [cb] + dlnpsob = log100 ! default (1000mb) if (lpsob) then call ufbint(lunin,obspsf,1,1,nlv,psfstr) if (obspsf(1,1) >= missing .or. & @@ -632,7 +642,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si endif enddo if (ncount_ps ==1) then - write(6,*) 'READ_FL_HDOB,WARNING!!psob: cannot find subtyep in the error,& + write(6,*) 'READ_FL_HDOB,WARNING!!psob: cannot find subtype in the error,& table,itype,iosub=',itypey,icsubtype(nc) write(6,*) 'read error table at colomn subtype as 0, error table column= ',ierr_ps endif @@ -896,9 +906,6 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si ! Get information from surface file necessary for conventional data call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr,zz) -! Process data passed quality control - igood = igood+1 - ! Process data thinning procedure on good data if (ithin > 0) then if (pflag == 0) then @@ -922,8 +929,6 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si end do endif ! pflag - ntmp = ndata ! counting moved into map3grids - ! Set data quality index for thinning if (thin4d) then timedif = zero @@ -937,26 +942,18 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si end do endif - call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - pob_cb,crit1,ndata,iout,igood,iiout,luse,.false.,.false.) + call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, & + dlat_earth,dlon_earth,pob_cb,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) + if (.not. luse) cycle loop_readsb2 - if(iiout > 0) isort(iiout) = 0 - if (ndata > ntmp) then - nodata = nodata+2 - if (luvob) & - nodata = nodata+2 - endif - isort(igood) = iout + if(rthin(ndata))usage=101._r_kind else ndata = ndata+1 - nodata = nodata+2 - if (luvob) & - nodata = nodata+2 - iout = ndata - isort(igood) = iout endif ! ithin + iout = ndata !------------------------------------------------------------------------------------------------- ! Write data into output arrays @@ -966,8 +963,11 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si if (lpsob) then qcm = ps_qm psoe = obserr*one_tenth ! convert from mb to cb + iqm=10 if (inflate_error) psoe = psoe*r1_2 - if (qcm > lim_qm ) psoe = psoe*1.0e6_r_kind + if (qcm > lim_qm ) then + psoe = psoe*1.0e6_r_kind + end if cdata_all( 1,iout)=psoe ! surface pressure error (cb) cdata_all( 2,iout)=dlon ! grid relative longitude cdata_all( 3,iout)=dlat ! grid relative latitude @@ -997,9 +997,12 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si ! Winds --- u, v components if (luvob) then woe = obserr + iqm = 12 if (pob_mb < r50) woe = woe*r1_2 if (inflate_error) woe = woe*r1_2 - if (qcm > lim_qm ) woe = woe*1.0e6_r_kind + if (qcm > lim_qm ) then + woe = woe*1.0e6_r_kind + end if if(regional .and. .not. fv3_regional)then u0 = uob v0 = vob @@ -1046,9 +1049,12 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si ! Temperature if(ltob) then toe = obserr + iqm = 10 if (pob_mb < r100) toe = toe*r1_2 if (inflate_error) toe = toe*r1_2 - if (qcm > lim_qm ) toe = toe*1.0e6_r_kind + if (qcm > lim_qm ) then + toe = toe*1.0e6_r_kind + end if cdata_all( 1,iout)=toe ! temperature error cdata_all( 2,iout)=dlon ! grid relative longitude cdata_all( 3,iout)=dlat ! grid relative latitude @@ -1081,11 +1087,14 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si if(lqob) then qoe = obserr*one_tenth ! RH (e.g. 0.98) qmaxerr = emerr + iqm = 11 if (inflate_error) then qmaxerr = emerr*r0_7 qoe = qoe*r1_2 end if - if (qcm > lim_qm ) qoe = qoe*1.0e6_r_kind + if (qcm > lim_qm ) then + qoe = qoe*1.0e6_r_kind + end if cdata_all( 1,iout)=qoe ! q error (RH e.g. 0.98) cdata_all( 2,iout)=dlon ! grid relative longitude cdata_all( 3,iout)=dlat ! grid relative latitude @@ -1116,8 +1125,11 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si ! Winds --- surface wind speed if (lspdob) then woe = obserr + iqm = 11 if (inflate_error) woe = woe*r1_2 - if (qcm > lim_qm ) woe = woe*1.0e6_r_kind + if (qcm > lim_qm ) then + woe = woe*1.0e6_r_kind + end if cdata_all( 1,iout)=woe ! wind error cdata_all( 2,iout)=dlon ! grid relative longitude cdata_all( 3,iout)=dlat ! grid relative latitude @@ -1142,6 +1154,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si cdata_all(22,iout)=r_prvstg(1,1) ! provider name cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name endif + if(usage >= r100)rusage(ndata)=.false. end do loop_readsb2 end do loop_msg2 @@ -1154,31 +1167,76 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si deallocate(presl_thin) call del3grids endif - + + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,ndata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' fl ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,& +! numrem,numqc,numthin +! If thinned data set quality mark to 14 + if (ithin > 0 .and. ithin <5) then + do i=1,nxdata + if(rthin(i))cdata_all(iqm,i)=14 + end do + end if + +! If flag to not save thinned data is set - compress data + if(pmot /= 1)then + do i=1,nxdata + +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + if(i > ndata)then + do k=1,nreal + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end if + end do + end if + end if + if(luvob)then + nodata=nodata+2*ndata + else + nodata=nodata+nxdata + end if + ! Write header record and data to output file for further processing - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - do k=1,nreal - cdata_out(k,i)=cdata_all(k,i) - end do - end do - deallocate(cdata_all) ! deallocate(etabl) - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) cdata_out - deallocate(cdata_out) -900 continue + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) + deallocate(cdata_all,rusage,rthin) + if(diagnostic_reg .and. ntest>0) write(6,*)'READ_FL_HDOB: ',& 'ntest, disterrmax=', ntest,disterrmax if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_FL_HDOB: ',& 'nvtest,vdisterrmax=',ntest,vdisterrmax if (ndata == 0) then - write(6,*)'READ_FL_HDOB: no data to process' + write(6,*)'READ_FL_HDOB: no data to process',obstype endif - write(6,*)'READ_FL_HDOB: nreal=',nreal + write(6,*)'READ_FL_HDOB: nreal=',nreal,obstype write(6,*)'READ_FL_HDOB: ntb,nread,ndata,nodata=',ntb,nread,ndata,nodata diff --git a/src/gsi/read_gfs_ozone_for_regional.f90 b/src/gsi/read_gfs_ozone_for_regional.f90 index e018d19cba..52e07087c0 100644 --- a/src/gsi/read_gfs_ozone_for_regional.f90 +++ b/src/gsi/read_gfs_ozone_for_regional.f90 @@ -319,9 +319,6 @@ subroutine read_gfs_ozone_for_regional call stop2(85) endif - allocate(vcoord(levs+1,nvcoord)) - vcoord(:,1:nvcoord) = nems_vcoord(:,1:nvcoord,1) - deallocate(nems_vcoord) call nemsio_close(gfile,iret=iret) if ( iret /= 0 ) call error_msg(trim(my_name),trim(filename),' ', & @@ -416,7 +413,7 @@ subroutine read_gfs_ozone_for_regional write(6,*)'READ_GFS_OZONE_FOR_REGIONAL: ***ERROR*** INVALID value for nvcoord=',sighead%nvcoord,filename call stop2(85) endif - else if ( use_gfs_ncio ) then + else if ( use_gfs_ncio ) then if (gfshead%nvcoord == 1) then do k=1,nsig_gfs+1 bk5(k) = gfsheadv%vcoord(k,1) @@ -437,6 +434,8 @@ subroutine read_gfs_ozone_for_regional call stop2(85) endif else + allocate(vcoord(levs+1,nvcoord)) + vcoord(:,1:nvcoord) = nems_vcoord(:,1:nvcoord,1) if (nvcoord == 1) then do k=1,nsig_gfs+1 bk5(k) = vcoord(k,1) @@ -456,6 +455,7 @@ subroutine read_gfs_ozone_for_regional write(6,*)'GET_GEFS_FOR_REGIONAL: ***ERROR*** INVALID value for nvcoord=',nvcoord call stop2(85) endif + deallocate(vcoord,nems_vcoord) end if ! Load reference temperature array (used by general coordinate) @@ -497,7 +497,6 @@ subroutine read_gfs_ozone_for_regional vector=.false. call general_sub2grid_create_info(grd_gfs,inner_vars,nlat_gfs,nlon_gfs,nsig_gfs,num_fields, & .not.regional,vector) - deallocate(vector) jcap_gfs_test=jcap_gfs call general_init_spec_vars(sp_gfs,jcap_gfs,jcap_gfs_test,grd_gfs%nlat,grd_gfs%nlon) if (hires .and. .not. use_gfs_nemsio .and. .not. use_gfs_ncio) then @@ -507,9 +506,6 @@ subroutine read_gfs_ozone_for_regional ! also want to set up regional grid structure variable grd_mix, which still has number of ! vertical levels set to nsig_gfs, but horizontal dimensions set to regional domain. - num_fields=2*nsig_gfs - allocate(vector(num_fields)) - vector=.false. call general_sub2grid_create_info(grd_mix,inner_vars,nlat,nlon,nsig_gfs,num_fields,regional,vector) deallocate(vector) diff --git a/src/gsi/read_goesglm.f90 b/src/gsi/read_goesglm.f90 index f087430092..8746fa27dd 100644 --- a/src/gsi/read_goesglm.f90 +++ b/src/gsi/read_goesglm.f90 @@ -76,9 +76,8 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) character(8) subset character(1) sidchr(8) - integer(i_kind) ireadmg,ireadsb,icntpnt,icount + integer(i_kind) ireadmg,ireadsb,icntpnt integer(i_kind) lunin,i - integer(i_kind) itx integer(i_kind) ihh,idd,idate,iret,im,iy,k integer(i_kind) nchanl,nreal,ilat,ilon integer(i_kind) lqm @@ -89,7 +88,6 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) integer(i_kind) nmsg ! message index integer(i_kind),parameter :: maxobs=2000000 integer(i_kind),dimension(5):: idate5 - integer(i_kind),allocatable,dimension(:):: isort,iloc real(r_kind) time real(r_kind) usage @@ -99,7 +97,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00 real(r_kind) vdisterrmax real(r_kind) timex,timeobs,toff,t4dv,zeps - real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out + real(r_kind),allocatable,dimension(:,:):: cdata_all !--- flash rate real(r_kind),allocatable,dimension(:,:):: cdata_flash,cdata_flash_h integer(i_kind) :: ndata_flash,ndata_flash_h @@ -122,6 +120,10 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) nreal=13 lob = obstype == 'goes_glm' + if(.not.lob) then + write(6,*) 'mix-up reading goes_glm ',obstype + return + end if ! . . . . @@ -139,8 +141,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) nmsg = 0 disterrmax=-9999.0_r_kind - allocate(cdata_all(nreal,maxobs),isort(maxobs)) - isort = 0 + allocate(cdata_all(nreal,maxobs)) cdata_all=zero nread=0 ntest=0 @@ -279,7 +280,6 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) if(ndata>maxobs) exit nodata=nodata+1 iout=ndata - isort(icntpnt)=iout if (ndata > maxobs) then write(6,*)'READ_GOESGLM: ***WARNING*** ndata > maxobs for ',obstype @@ -291,21 +291,19 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) usage = zero if (iuse_light(nlighttype) <= 0)usage=100._r_kind - if (lob) then - cdata_all(1,iout) =loe ! lightning observation error - cdata_all(2,iout) =dlon ! grid relative longitude - cdata_all(3,iout) =dlat ! grid relative latitude - cdata_all(4,iout) =iout ! lightning obs - cdata_all(5,iout) =rstation_id ! station id - cdata_all(6,iout) =t4dv ! analysis time - cdata_all(7,iout) =nlighttype ! type - cdata_all(8,iout) =lmerr ! lightning max error - cdata_all(9,iout) =lqm ! quality mark - cdata_all(10,iout)=loe ! original lightning obs error loe - cdata_all(11,iout)=usage ! usage parameter - cdata_all(12,iout)=dlon_earth*rad2deg ! earth relative lon (degrees) - cdata_all(13,iout)=dlat_earth*rad2deg ! earth relative lat (degrees) - end if + cdata_all(1,iout) =loe ! lightning observation error + cdata_all(2,iout) =dlon ! grid relative longitude + cdata_all(3,iout) =dlat ! grid relative latitude + cdata_all(4,iout) =iout ! lightning obs + cdata_all(5,iout) =rstation_id ! station id + cdata_all(6,iout) =t4dv ! analysis time + cdata_all(7,iout) =nlighttype ! type + cdata_all(8,iout) =lmerr ! lightning max error + cdata_all(9,iout) =lqm ! quality mark + cdata_all(10,iout)=loe ! original lightning obs error loe + cdata_all(11,iout)=usage ! usage parameter + cdata_all(12,iout)=dlon_earth*rad2deg ! earth relative lon (degrees) + cdata_all(13,iout)=dlat_earth*rad2deg ! earth relative lat (degrees) ! end loop on read line BUFR @@ -323,30 +321,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) call closbf(lunin) ! Write header record and data to output file for further processing - allocate(iloc(ndata)) - icount=0. - do i=1,maxobs - if(isort(i) > 0)then - icount=icount+1 - iloc(icount)=isort(i) - end if - end do - if(ndata /= icount)then - write(6,*) ' READ_GOESGLM: mix up in read_goesglm ,ndata,icount ',ndata,icount - call stop2(50) - end if - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - itx=iloc(i) - do k=1,nreal - cdata_out(k,i)=cdata_all(k,itx) - end do - end do - - deallocate(iloc,isort,cdata_all) - -! . . . . ! Call to the subroutine that transforms lightning strikes into lightning flash rate @@ -361,9 +336,9 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) allocate(cdata_flash_h(nreal,ndata_flash_h)) call convert_to_flash_rate & - (nreal,ndata,cdata_out,ndata_flash_h,cdata_flash_h,ndata_flash) + (nreal,ndata,cdata_all,ndata_flash_h,cdata_flash_h,ndata_flash) - deallocate(cdata_out) + deallocate(cdata_all) ndata=ndata_flash allocate(cdata_flash(nreal,ndata)) @@ -388,8 +363,8 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) else ! ndata=0 write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) cdata_out - deallocate(cdata_out) + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) + deallocate(cdata_all) end if !! if(ndata =/ 0) then diff --git a/src/gsi/read_goesimgr_skycover.f90 b/src/gsi/read_goesimgr_skycover.f90 index dda9aad6f4..97eeb5e695 100644 --- a/src/gsi/read_goesimgr_skycover.f90 +++ b/src/gsi/read_goesimgr_skycover.f90 @@ -50,14 +50,14 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti use constants, only: zero,one_tenth,one,deg2rad,half,& three,four, r60inv,r10,r100,r2000 - use convinfo, only: nconvtype, & - icuse,ictype,ioctype,& - ithin_conv,rmesh_conv,pmesh_conv,ctwind - use convthin, only: make3grids,map3grids,del3grids,use_all + use convinfo, only: nconvtype,icuse,ictype,ioctype,& + ithin_conv,rmesh_conv,pmesh_conv,ctwind,pmot_conv +! use convinfo, only: icsubtype + use convthin, only: make3grids,map3grids_m,del3grids,use_all use gridmod, only: regional,nlon,nlat,nsig,tll2xy,txy2ll,& rlats,rlons use deter_sfc_mod, only: deter_sfc2 - use obsmod, only: bmiss,ran01dom + use obsmod, only: bmiss,ran01dom,reduce_diag use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d use adjust_cloudobs_mod, only: adjust_goescldobs use mpimod, only: npe @@ -95,9 +95,8 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti integer(i_kind) :: iret,kx,pflag,nlevp,nmind,levs,idomsfc integer(i_kind) :: low_cldamt_qc,mid_cldamt_qc,hig_cldamt_qc,tcamt_qc integer(i_kind) :: ithin,klat1,klon1,klonp1,klatp1,kk,k,ilat,ilon,nchanl - integer(i_kind) :: iout,ntmp,iiout,maxobs,icount,itx,iuse,idate,ierr + integer(i_kind) :: iout,maxobs,iuse,idate,ierr integer(i_kind),dimension(5) :: idate5 - integer(i_kind),allocatable,dimension(:):: isort,iloc real(r_kind) :: dlat,dlon,dlat_earth,dlon_earth,toff,t4dv real(r_kind) :: dlat_earth_deg,dlon_earth_deg real(r_kind) :: dx,dx1,dy,dy1,w00,w10,w01,w11,crit1,timedif,tdiff @@ -106,10 +105,13 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti real(r_kind) :: low_cldamt,mid_cldamt,hig_cldamt,usage,zz,sfcr,rstation_id real(r_kind),allocatable,dimension(:):: presl_thin real(r_kind),dimension(nsig):: presl - real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out + real(r_kind),allocatable,dimension(:,:):: cdata_all real(r_double),dimension(9):: hdr real(r_double),dimension(3):: goescld - + logical,allocatable,dimension(:)::rthin,rusage + logical save_all +! integer(i_kind) numthin,numqc,numrem,numall + integer(i_kind) nxdata,pmot logical :: outside,ithinp,luse @@ -196,8 +198,7 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti end do maxobs=ntb - allocate(cdata_all(nreal,maxobs),isort(maxobs)) - isort = 0 + allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs)) cdata_all=zero nread=0 nchanl=0 @@ -211,211 +212,240 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti call openbf(lunin,'IN',lunin) call datelen(10) - loop_msg: do while (ireadmg(lunin,subset,idate) == 0) - loop_readsb: do while (ireadsb(lunin) == 0) - ntb=ntb+1 - ! - Extract type, date, and location information - call ufbint(lunin,hdr,9,1,iret,hdrstr) - - ! - Compare relative obs time with window. If obs - ! - falls outside of window, don't use this obs - idate5(1) = hdr(2) ! year - idate5(2) = hdr(3) ! month - idate5(3) = hdr(4) ! day - idate5(4) = hdr(5) ! hours - idate5(5) = hdr(6) ! minutes - call w3fs21(idate5,nmind) - rminobs=real(nmind,8)+(real(hdr(7),8)*r60inv)!convert the seconds of the ob to minutes and store to rminobs - t4dv = (rminobs-real(iwinbgn,r_kind))*r60inv - tdiff=(rminobs-gstime)*r60inv !GS time is the analysis time in minutes from w3fs21 - - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) cycle loop_readsb - else - ! - Check to make sure ob is within convinfo time window (ctwind) and - ! - is within overwall time window twind (usually +-3) - if( (abs(tdiff) > ctwind(nc)) .or. (abs(tdiff) > twind) )cycle loop_readsb - endif - - - kx=999_i_kind !hardwire typ to 999 - if(abs(hdr(8))>r90 .or. abs(hdr(9))>r360) cycle loop_readsb - if(hdr(9)== r360)hdr(9)=hdr(9)-r360 - if(hdr(9) < zero)hdr(9)=hdr(9)+r360 - dlon_earth_deg = hdr(9) - dlat_earth_deg = hdr(8) - dlon_earth=hdr(9)*deg2rad - dlat_earth=hdr(8)*deg2rad - nread=nread+1 - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate - if(outside) cycle loop_readsb ! check to see if outside regional domain - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif + pmot=nint(pmot_conv(nc)) + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. + rusage = .true. + rthin = .false. + use_all=.true. + + loop_msg: do while (ireadmg(lunin,subset,idate) == 0) + loop_readsb: do while (ireadsb(lunin) == 0) + ntb=ntb+1 + ! - Extract type, date, and location information + call ufbint(lunin,hdr,9,1,iret,hdrstr) + + ! - Compare relative obs time with window. If obs + ! - falls outside of window, don't use this obs + idate5(1) = hdr(2) ! year + idate5(2) = hdr(3) ! month + idate5(3) = hdr(4) ! day + idate5(4) = hdr(5) ! hours + idate5(5) = hdr(6) ! minutes + call w3fs21(idate5,nmind) + rminobs=real(nmind,8)+(real(hdr(7),8)*r60inv)!convert the seconds of the ob to minutes and store to rminobs + t4dv = (rminobs-real(iwinbgn,r_kind))*r60inv + tdiff=(rminobs-gstime)*r60inv !GS time is the analysis time in minutes from w3fs21 + + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle loop_readsb + else + ! - Check to make sure ob is within convinfo time window (ctwind) and + ! - is within overwall time window twind (usually +-3) + if( (abs(tdiff) > ctwind(nc)) .or. (abs(tdiff) > twind) )cycle loop_readsb + endif - ! Read in the obs - goescld=bmiss - call ufbint(lunin,goescld,3,1,levs,goescldstr_new) - if (goescld(3) > r0_01_bmiss) then + + kx=999_i_kind !hardwire typ to 999 + if(abs(hdr(8))>r90 .or. abs(hdr(9))>r360) cycle loop_readsb + if(hdr(9)== r360)hdr(9)=hdr(9)-r360 + if(hdr(9) < zero)hdr(9)=hdr(9)+r360 + dlon_earth_deg = hdr(9) + dlat_earth_deg = hdr(8) + dlon_earth=hdr(9)*deg2rad + dlat_earth=hdr(8)*deg2rad + nread=nread+1 + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate + if(outside) cycle loop_readsb ! check to see if outside regional domain + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + + ! Read in the obs + goescld=bmiss + call ufbint(lunin,goescld,3,1,levs,goescldstr_new) + if (goescld(3) > r0_01_bmiss) then ! if ob is missing, look for it in old BUFR mnemonic sequence - goescld=bmiss - call ufbint(lunin,goescld,3,1,levs,goescldstr) - if (goescld(3) > r0_01_bmiss) cycle loop_readsb !If obs are missing, cycle - endif - c_prvstg=cspval - c_sprvstg=cspval - - ! - Set station ID - rstation_id=goescld(1) + goescld=bmiss + call ufbint(lunin,goescld,3,1,levs,goescldstr) + if (goescld(3) > r0_01_bmiss) cycle loop_readsb !If obs are missing, cycle + endif + c_prvstg=cspval + c_sprvstg=cspval + + ! - Set station ID + rstation_id=goescld(1) - ithin=ithin_conv(nc) - ithinp = ithin > 0 .and. pflag /= 0 - - ! - Thin in vertical - note we can only thin in the horizontal - ! - since sky cover is a 2D field. So this branch should never run - ! - unless we get info about the vertical location of the clouds in the - ! - future. Leaving here as a 'just-in-case' measure. - if(ithinp )then -! Interpolate guess pressure profile to observation location - klon1= int(dlon); klat1= int(dlat) - dx = dlon-klon1; dy = dlat-klat1 - dx1 = one-dx; dy1 = one-dy - w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy - - klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) - if (klon1==0) klon1=nlon - klatp1=min(nlat,klat1+1); klonp1=klon1+1 - if (klonp1==nlon+1) klonp1=1 + ithin=ithin_conv(nc) + ithinp = ithin > 0 .and. pflag /= 0 + + ! - Thin in vertical - note we can only thin in the horizontal + ! - since sky cover is a 2D field. So this branch should never run + ! - unless we get info about the vertical location of the clouds in the + ! - future. Leaving here as a 'just-in-case' measure. + if(ithinp )then +! Interpolate guess pressure profile to observation location + klon1= int(dlon); klat1= int(dlat) + dx = dlon-klon1; dy = dlat-klat1 + dx1 = one-dx; dy1 = one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) + if (klon1==0) klon1=nlon + klatp1=min(nlat,klat1+1); klonp1=klon1+1 + if (klonp1==nlon+1) klonp1=1 + do kk=1,nsig + presl(kk)=w00*prsl_full(klat1 ,klon1 ,kk) + & + w10*prsl_full(klatp1,klon1 ,kk) + & + w01*prsl_full(klat1 ,klonp1,kk) + & + w11*prsl_full(klatp1,klonp1,kk) + end do + end if + + iuse=icuse(nc) + + ! General block for data thinning - if requested + if (ithin > 0 .and. iuse >=0) then + ! - Set data quality index for thinning + if (thin4d) then + timedif = zero + else + timedif=abs(t4dv-toff) + endif + + crit1 = timedif/r6+half + + ! - simple 1-to-1 mapping of vertical levels when no thinning in the vertical + if (pflag==0) then do kk=1,nsig - presl(kk)=w00*prsl_full(klat1 ,klon1 ,kk) + & - w10*prsl_full(klatp1,klon1 ,kk) + & - w01*prsl_full(klat1 ,klonp1,kk) + & - w11*prsl_full(klatp1,klonp1,kk) + presl_thin(kk)=presl(kk) end do - end if - - iuse=icuse(nc) - - ! General block for data thinning - if requested - if (ithin > 0 .and. iuse >=0) then - ntmp=ndata ! counting moved to map3gridS - ! - Set data quality index for thinning - if (thin4d) then - timedif = zero - else - timedif=abs(t4dv-toff) - endif - - crit1 = timedif/r6+half - - ! - simple 1-to-1 mapping of vertical levels when no thinning in the vertical - if (pflag==0) then - do kk=1,nsig - presl_thin(kk)=presl(kk) - end do - endif - ppb=one_tenth*1013.25_r_kind !number is irrelevant for 2D - set to standard SLP -> 1013.25 and convert from mb to cb - call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - ppb,crit1,ndata,iout,ntb,iiout,luse,.false.,.false.) - - if (.not. luse) cycle loop_readsb - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(ntb)=iout - else ! - no thinnning - ndata=ndata+1 - nodata=nodata+1 - iout=ndata - isort(ntb)=iout - endif - - !- Set usage variable - usage = 0 - if(iuse <= 0)usage=r100 - - ! Get information from surface file necessary for conventional data here - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr,zz) - - ! - Obtain the ob and tune the QC marks for ob error tuning a bit later - - call adjust_goescldobs(goescld(3),tdiff,dlat_earth,dlon_earth, & - low_cldamt,low_cldamt_qc,mid_cldamt,mid_cldamt_qc, & - hig_cldamt,hig_cldamt_qc,tcamt,tcamt_qc) - - - if(tcamt_qc==15 .or. tcamt_qc==12 .or. tcamt_qc==9 .or. tcamt_qc==8) usage=r100 - tcamt_oe=20.0_r_kind - if(tcamt_qc==1) tcamt_oe=tcamt_oe*1.25_r_kind - if(tcamt_qc==2) tcamt_oe=tcamt_oe*1.50_r_kind - if(tcamt_qc==3) tcamt_oe=tcamt_oe*1.75_r_kind - - cdata_all( 1,iout)=tcamt_oe ! obs error - cdata_all( 2,iout)=dlon ! grid relative longitude - cdata_all( 3,iout)=dlat ! grid relative latitude - cdata_all( 4,iout)=tcamt ! total cloud amount (%) - cdata_all( 5,iout)=rstation_id ! station ID - cdata_all( 6,iout)=t4dv ! time - cdata_all( 7,iout)=nc ! type - cdata_all( 8,iout)=tcamt_qc ! quality mark - cdata_all( 9,iout)=usage ! usage parameter - cdata_all(10,iout)=idomsfc ! dominate surface type - cdata_all(11,iout)=tsavg ! skin temperature - cdata_all(12,iout)=ff10 ! 10 meter wind factor - cdata_all(13,iout)=sfcr ! surface roughness - cdata_all(14,iout)=dlon_earth_deg ! earth relative longitude (degrees) - cdata_all(15,iout)=dlat_earth_deg ! earth relative latitude (degrees) - cdata_all(16,iout)=bmiss ! station elevation (m) - cdata_all(17,iout)=bmiss ! observation height (m) - cdata_all(18,iout)=zz ! terrain height at ob location - cdata_all(19,iout)=r_prvstg(1,1) ! provider name - cdata_all(20,iout)=r_sprvstg(1,1) ! subprovider name - - enddo loop_readsb - - enddo loop_msg - -! Close unit to bufr file - call closbf(lunin) -! Deallocate arrays used for thinning data - if (.not.use_all) then - deallocate(presl_thin) - call del3grids - endif + endif + ppb=one_tenth*1013.25_r_kind !number is irrelevant for 2D - set to standard SLP -> 1013.25 and convert from mb to cb + call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, & + dlat_earth,dlon_earth,ppb,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) + + if (.not. luse) cycle loop_readsb + else ! - no thinnning + ndata=ndata+1 + endif + iout=ndata + + !- Set usage variable + usage = 0 + if(iuse <= 0)usage=r100 + + ! Get information from surface file necessary for conventional data here + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr,zz) + + ! - Obtain the ob and tune the QC marks for ob error tuning a bit later + + call adjust_goescldobs(goescld(3),tdiff,dlat_earth,dlon_earth, & + low_cldamt,low_cldamt_qc,mid_cldamt,mid_cldamt_qc, & + hig_cldamt,hig_cldamt_qc,tcamt,tcamt_qc) + + + if(tcamt_qc==15 .or. tcamt_qc==12 .or. tcamt_qc==9 .or. tcamt_qc==8) usage=r100 + tcamt_oe=20.0_r_kind + if(tcamt_qc==1) tcamt_oe=tcamt_oe*1.25_r_kind + if(tcamt_qc==2) tcamt_oe=tcamt_oe*1.50_r_kind + if(tcamt_qc==3) tcamt_oe=tcamt_oe*1.75_r_kind + + cdata_all( 1,iout)=tcamt_oe ! obs error + cdata_all( 2,iout)=dlon ! grid relative longitude + cdata_all( 3,iout)=dlat ! grid relative latitude + cdata_all( 4,iout)=tcamt ! total cloud amount (%) + cdata_all( 5,iout)=rstation_id ! station ID + cdata_all( 6,iout)=t4dv ! time + cdata_all( 7,iout)=nc ! type + cdata_all( 8,iout)=tcamt_qc ! quality mark + cdata_all( 9,iout)=usage ! usage parameter + cdata_all(10,iout)=idomsfc ! dominate surface type + cdata_all(11,iout)=tsavg ! skin temperature + cdata_all(12,iout)=ff10 ! 10 meter wind factor + cdata_all(13,iout)=sfcr ! surface roughness + cdata_all(14,iout)=dlon_earth_deg ! earth relative longitude (degrees) + cdata_all(15,iout)=dlat_earth_deg ! earth relative latitude (degrees) + cdata_all(16,iout)=bmiss ! station elevation (m) + cdata_all(17,iout)=bmiss ! observation height (m) + cdata_all(18,iout)=zz ! terrain height at ob location + cdata_all(19,iout)=r_prvstg(1,1) ! provider name + cdata_all(20,iout)=r_sprvstg(1,1) ! subprovider name + if(usage >=r100)rusage(ndata)=.false. + + enddo loop_readsb + + enddo loop_msg + +! Close unit to bufr file + call closbf(lunin) +! Deallocate arrays used for thinning data + if (.not.use_all) then + deallocate(presl_thin) + call del3grids + endif ! Normal exit - -! Write header record and data to output file for further processing - allocate(iloc(ndata)) - icount=0 - do i=1,maxobs - if(isort(i) > 0)then - icount=icount+1 - iloc(icount)=isort(i) + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' sky ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin +! If thinned data set usage + if (ithin > 0 .and. ithin <5) then + do i=1,nxdata + if(rthin(i))then + cdata_all(9,i)=100._r_kind + cdata_all(8,i)=14 + end if + end do end if - end do - if(ndata /= icount)then - write(6,*) myname,': ndata and icount do not match STOPPING...ndata,icount ',ndata,icount - call stop2(50) +! If flag to not save thinned data is set - compress data + if(pmot /= 1)then + do i=1,nxdata +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + if(i > ndata)then + do k=1,nreal + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end if + end do + end if + nodata=nodata+ndata end if - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - itx=iloc(i) - do k=1,nreal - cdata_out(k,i)=cdata_all(k,itx) - end do - end do - deallocate(iloc,isort,cdata_all) + +! Write header record and data to output file for further processing - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata - write(lunout) cdata_out + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) - deallocate(cdata_out) + deallocate(cdata_all,rusage,rthin) if (ndata == 0) then write(6,*)myname,'no read_goesimgr_skycover data' diff --git a/src/gsi/read_l2bufr_mod.f90 b/src/gsi/read_l2bufr_mod.f90 index e0619ed1a8..9c9ad73afe 100644 --- a/src/gsi/read_l2bufr_mod.f90 +++ b/src/gsi/read_l2bufr_mod.f90 @@ -56,9 +56,9 @@ module read_l2bufr_mod public :: range_max,del_time,l2superob_only,elev_angle_max,del_azimuth public :: minnum,del_range,del_elev - public :: invtllv,radar_sites,radar_box,radar_rmesh,radar_zmesh + public :: invtllv,radar_sites,radar_box,radar_rmesh,radar_zmesh,radar_pmot - integer(i_kind) minnum + integer(i_kind) minnum,radar_pmot real(r_kind) del_azimuth,del_elev,del_range,del_time,elev_angle_max,range_max,radar_rmesh,radar_zmesh logical l2superob_only,radar_sites,radar_box @@ -100,6 +100,14 @@ subroutine initialize_superob_radar radar_box=.false. radar_rmesh=10._r_kind radar_zmesh=500._r_kind + +! radar_pmot of 0,1,2,3 will save different sets of obs output +! radar_pmot - all obs - thin obs +! radar_pmot - all obs +! radar_pmot - use obs +! radar_pmot - use obs + thin obs + + radar_pmot = 2 end subroutine initialize_superob_radar subroutine radar_bufr_read_all(npe,mype) @@ -749,6 +757,7 @@ subroutine radar_bufr_read_all(npe,mype) write(6,*)' nobs_hrbin=',nobs_hrbin1 write(6,*)' nrange_max=',nrange_max1 end if + deallocate(icount) ! Prepare to create superobs and write out. open(inbufr,file='radar_supobs_from_level2',form='unformatted',iostat=iret) @@ -946,6 +955,7 @@ subroutine radar_bufr_read_all(npe,mype) close(inbufr) close(inbufr) end if + deallocate(indx) deallocate(bins_work,bins,ibins2) if(l2superob_only) then call mpi_finalize(ierror) diff --git a/src/gsi/read_mitm_mxtm.f90 b/src/gsi/read_mitm_mxtm.f90 index fbfe310bd4..393e997e32 100644 --- a/src/gsi/read_mitm_mxtm.f90 +++ b/src/gsi/read_mitm_mxtm.f90 @@ -84,7 +84,7 @@ subroutine read_mitm_mxtm(nread,ndata,nodata,infile,obstype,lunout,gstime,sis,no real(r_kind) :: stnelev real(r_kind) :: usage,tsavg,ff10,sfcr,zz real(r_kind) :: mxtmoe,mitmoe,oberr,qtflg - real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out + real(r_kind),allocatable,dimension(:,:):: cdata_all integer(i_kind) :: ikx(100:199) !order number of report type in convinfo file integer(i_kind) :: kxall(100:199) @@ -407,19 +407,11 @@ subroutine read_mitm_mxtm(nread,ndata,nodata,infile,obstype,lunout,gstime,sis,no ndata=iout nodata=iout - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - do k=1,nreal - cdata_out(k,i)=cdata_all(k,i) - end do - end do - call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata - write(lunout) cdata_out + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) deallocate(cdata_all) - deallocate(cdata_out) call destroy_rjlists if (lhilbert) call destroy_hilbertcurve diff --git a/src/gsi/read_nsstbufr.f90 b/src/gsi/read_nsstbufr.f90 index d7a3472dd0..f287dbd0b8 100644 --- a/src/gsi/read_nsstbufr.f90 +++ b/src/gsi/read_nsstbufr.f90 @@ -667,6 +667,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & ! Close unit to bufr file 1020 continue + deallocate(data_all) if (oberrflg) deallocate(etabl) call closbf(lunin) close(lunin) diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index dab159bd0a..aa0f11b4e3 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -1600,6 +1600,7 @@ subroutine read_obs(ndata,mype) string='READ_RADAR' else if (sis == 'l2rw') then if (l2rwthin)then + write(6,*)'READ_OBS: radial wind,read_radar_l2rw,dsis=',sis call read_radar_l2rw(npuse,nouse,lunout,obstype,sis,nobs_sub1(1,i),hgtl_full) string='READ_RADAR_L2RW_NOVADQC' else @@ -1910,7 +1911,7 @@ subroutine read_obs(ndata,mype) ! Process satellite lightning observations (e.g. GOES/GLM) else if(ditype(i) == 'light')then if (obstype == 'goes_glm' ) then - call read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twind,sis) + call read_goesglm(nread,npuse,nodata,infile,obstype,lunout,twind,sis) string='READ_GOESGLM' endif @@ -1955,6 +1956,7 @@ subroutine read_obs(ndata,mype) ! Deallocate arrays containing full horizontal surface fields call destroy_sfc ! Sum and distribute number of obs read and used for each input ob group + call mpi_allreduce(ndata1,ndata,ndat*3,mpi_integer,mpi_sum,mpi_comm_world,& ierror) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index eaece05451..87d5aa4bd8 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -188,6 +188,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use obsmod, only: iadate,oberrflg,perturb_obs,perturb_fact,ran01dom,hilbert_curve use obsmod, only: blacklst,offtime_data,bmiss,ext_sonde,time_offset, vad_near_analtime + use obsmod, only: reduce_diag use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof,ntail,taillist,idx_tail,npredt,predt, & aircraft_t_bc_ext,ntail_update,max_tail,nsort,itail_sort,idx_sort,timelist use converr,only: etabl @@ -201,8 +202,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use convb_t,only: btabl_t use convb_uv,only: btabl_uv use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen,thin4d - use convthin, only: make3grids,map3grids,map3grids_m,del3grids,use_all - use convthin_time, only: make3grids_tm,map3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm + use convthin, only: make3grids,map3grids_m,del3grids,use_all + use convthin_time, only: make3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm use qcmod, only: errormod,errormod_aircraft,noiqc,newvad,njqc use qcmod, only: pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres use qcmod, only: nrand @@ -268,7 +269,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& logical outside,driftl,convobs,inflate_error logical sfctype, global_2m_land logical luse,ithinp,windcorr - logical patch_fog + logical patch_fog,save_all logical aircraftset,aircraftobs,aircraftobst,aircrafttype logical acft_profl_file logical,allocatable,dimension(:,:):: lmsg ! set true when convinfo entry id found in a message @@ -290,17 +291,17 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& character(1) cdummy logical lhilbert - integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2,icount,iiout - integer(i_kind) lunin,i,maxobs,j,idomsfc,it29,nmsgmax,mxtb + integer(i_kind) ireadmg,ireadsb,iqm,iuse,pmot + integer(i_kind) lunin,i,maxobs,j,idomsfc,it29,nmsgmax,mxtb,maxall integer(i_kind) kk,klon1,klat1,klonp1,klatp1 - integer(i_kind) nc,nx,isflg,ntread,itx,ii,ncsave + integer(i_kind) nc,isflg,ntread,ii,ncsave,nxdata,nx integer(i_kind) ihh,idd,idate,iret,im,iy,k,levs integer(i_kind) metarcldlevs,metarwthlevs,cldseqlevs,cld2seqlevs integer(i_kind) kx,kx0,nreal,nchanl,ilat,ilon,ithin integer(i_kind) cat,zqm,pwq,sstq,qm,lim_qm,lim_zqm,gustqm,visqm,tdqm,mxtmqm,mitmqm,howvqm,cldchqm integer(i_kind) lim_tqm,lim_qqm integer(i_kind) nlevp ! vertical level for thinning - integer(i_kind) ntmp,iout + integer(i_kind) iout integer(i_kind) pflag,irec,zflag integer(i_kind) ntest,nvtest,iosub,ixsub,isubsub,iobsub integer(i_kind) kl,k1,k2,k1_ps,k1_q,k1_t,k1_uv,k1_pw,k2_q,k2_t,k2_uv,k2_pw,k2_ps @@ -317,7 +318,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& integer(i_kind),dimension(255):: pqm,qqm,tqm,wqm,pmq integer(i_kind),dimension(nconvtype)::ntxall integer(i_kind),dimension(nconvtype+1)::ntx - integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep + integer(i_kind),allocatable,dimension(:):: nrep integer(i_kind),allocatable,dimension(:,:):: tab integer(i_kind) ibfms,thisobtype_usage integer(i_kind) iwmo,ios @@ -337,7 +338,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& real(r_kind) del,terrmin,werrmin,perrmin,qerrmin,pwerrmin,del_ps,del_q,del_t,del_uv,del_pw real(r_kind) pjbmin,qjbmin,tjbmin,wjbmin real(r_kind) tsavg,ff10,sfcr,zz - real(r_kind) crit1,timedif,xmesh,pmesh,pmot,ptime ! thinning parameter + real(r_kind) crit1,timedif,xmesh,pmesh,ptime ! thinning parameter real(r_kind) time_correction real(r_kind) tcamt,lcbas,ceiling real(r_kind) tcamt_oe,lcbas_oe @@ -381,10 +382,12 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& integer(i_kind) indexx real(r_kind) dentrip,dentrip_tmp,vmin,vmax,rmesh_tmp,pmesh_tmp,prest integer(i_kind) ntime_max,ntime_tmp,itype,ikx +! integer(i_kind) numthin,numqc,numrem,numall integer(i_kind),dimension(24) :: ntype_arr integer(i_kind),allocatable,dimension(:,:) :: index_arr real(r_kind),allocatable,dimension(:,:,:) :: data_hilb real(r_kind),allocatable,dimension(:) :: rlat_hil,rlon_hil,height,wtob,wght_hilb + logical, allocatable,dimension(:) :: rusage,rthin ! end of block @@ -434,8 +437,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! character(len=8) :: cval ! equivalence (rval,cval) ! character(7) flnm - integer:: icase,klev,ikkk,tkk - real:: diffhgt,diffuu,diffvv + + integer:: icase,klev,ikkk,tkk + real:: diffhgt,diffuu,diffvv + integer,dimension(3)::kcount real(r_double),dimension(3,1500):: fcstdat logical print_verbose @@ -447,12 +452,14 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Initialize variables + kcount=0 vdisterrmax=zero zflag=0 nreal=0 satqc=zero tob = obstype == 't' - uvob = obstype == 'uv' ; if (twodvar_regional) uvob = uvob .or. obstype == 'wspd10m' .or. obstype == 'uwnd10m' .or. obstype == 'vwnd10m' + uvob = obstype == 'uv' + if (twodvar_regional) uvob = uvob .or. obstype == 'wspd10m' .or. obstype == 'uwnd10m' .or. obstype == 'vwnd10m' spdob = obstype == 'spd' psob = obstype == 'ps' qob = obstype == 'q' @@ -475,52 +482,96 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& tdob .or. mxtmob .or. mitmob .or. pmob .or. howvob .or. & tcamtob .or. lcbasob .or. cldchob aircraftobst=.false. + iqm = 0 + iuse = 0 if(tob)then nreal=25 + iqm = 10 + iuse = 12 else if(uvob) then nreal=26 + iqm = 12 + iuse = 14 else if(spdob) then nreal=24 + iqm = 11 + iuse = 13 else if(psob) then nreal=20 + iqm=10 + iuse = 12 else if(qob) then nreal=26 + iqm = 11 + iuse = 13 else if(pwob) then nreal=20 + iqm = 9 + iuse = 11 else if(sstob) then if (nst_gsi > 0) then nreal=18 + nstinfo else nreal=18 end if + iqm = 11 + iuse = 13 else if(gustob) then nreal=21 + iqm = 11 + iuse = 12 else if(visob) then nreal=18 + iqm = 9 + iuse = 10 else if(tdob) then nreal=25 + iqm = 11 + iuse = 13 else if(mxtmob) then nreal=24 + iqm = 10 + iuse = 12 else if(mitmob) then nreal=24 + iqm = 10 + iuse = 12 else if(pmob) then nreal=24 + iqm = 11 + iuse = 13 else if(howvob) then nreal=23 + iqm = 9 + iuse = 11 else if(metarcldobs) then nreal=27 + iqm = 0 + iuse = 22 else if(goesctpobs) then nreal=8 + iqm = 0 + iuse = 8 else if(tcamtob) then nreal=20 + iqm = 8 + iuse = 9 else if(lcbasob) then nreal=23 + iqm = 8 + iuse = 9 else if(cldchob) then nreal=18 + iqm = 9 + iuse = 10 else write(6,*) ' illegal obs type in READ_PREPBUFR ',obstype call stop2(94) end if + if(iuse < 1) then + write(6,*) ' mix up in read_prepbufr iuse ' + call stop2(49) + end if ! Set qc limits based on noiqc flag if (noiqc) then @@ -606,10 +657,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& !! get message and subset counts call getcount_bufr(infile,nmsgmax,mxtb) - allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax)) + allocate(lmsg(nmsgmax,ntread),tab(mxtb,2),nrep(nmsgmax)) lmsg = .false. maxobs=0 + maxall=0 tab=0 nmsg=0 nrep=0 @@ -777,11 +829,12 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if end if end do matchloop + call ufbint(lunin,levdat,1,255,levs,levstr) + maxall=maxall+max(1,levs) ! Save information for next read if(ncsave /= 0) then - call ufbint(lunin,levdat,1,255,levs,levstr) maxobs=maxobs+max(1,levs) nx=1 if(ithin_conv(ncsave) > 0 .and. ithin_conv(ncsave) <5)then @@ -791,7 +844,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if tab(ntb,1)=ncsave tab(ntb,2)=nx - tab(ntb,3)=levs lmsg(nmsg,nx) = .true. end if @@ -837,9 +889,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! loop over convinfo file entries; operate on matches - allocate(cdata_all(nreal,maxobs),isort(maxobs)) - isort = 0 - cdata_all=zero + allocate(cdata_all(nreal,maxall),rusage(maxall),rthin(maxall)) nread=0 ntest=0 nvtest=0 @@ -847,22 +897,27 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ilon=2 ilat=3 rmesh=zero - pmot=zero pmesh=zero ptime=zero xmesh=zero pflag=0 + save_all=.true. + rusage = .true. + rthin = .false. + ndata = 0 loop_convinfo: do nx=1, ntread - use_all_tm = .true. + use_all_tm = .true. use_all = .true. ithin=0 + pmot=0 if(nx > 1) then nc=ntx(nx) ithin=ithin_conv(nc) + pmot=nint(pmot_conv(nc)) if (ithin > 0 .and. ithin <5) then rmesh=rmesh_conv(nc) pmesh=pmesh_conv(nc) - pmot=pmot_conv(nc) + ptime=ptime_conv(nc) if(pmesh > zero .and. ithin ==1) then pflag=1 @@ -906,10 +961,13 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& enddo endif endif - if(print_verbose) write(6,*)'READ_PREPBUFR: at line 779: obstype,ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime=',& - trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime,ithin + if(print_verbose) write(6,*)'READ_PREPBUFR: obstype,ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime=',& + trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime,ithin,ndata,nc endif endif + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all = .false. + if(pmot /= 2 .and. pmot /= 0)save_all=.true. call closbf(lunin) @@ -922,8 +980,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ntb = 0 nmsg = 0 - icntpnt=0 - icntpnt2=0 disterrmax=-9999.0_r_kind irec = 0 loop_msg: do while (ireadmg(lunin,subset,idate)== 0) @@ -938,9 +994,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& nmsg = nmsg+1 if(.not.lmsg(nmsg,nx)) then - do i=ntb+1,ntb+nrep(nmsg) - icntpnt2=icntpnt2+tab(i,3) - end do ntb=ntb+nrep(nmsg) cycle loop_msg ! no useable reports this mesage, skip ahead report count end if @@ -949,10 +1002,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! use msg lookup table to decide which messages to skip ! use report id lookup table to only process matching reports ntb = ntb+1 - if(icntpnt < icntpnt2)icntpnt=icntpnt2 - icntpnt2=icntpnt2+tab(ntb,3) - nc=tab(ntb,1) - if(nc <= 0 .or. tab(ntb,2) /= nx) cycle loop_readsb + if(tab(ntb,1) <= 0 .or. tab(ntb,2) /= nx) cycle loop_readsb ! Extract type, date, and location information call ufbint(lunin,hdr,8,1,iret,hdstr) @@ -1091,6 +1141,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Balloon drift information available for these data driftl=kx==120.or.kx==220.or.kx==221 + nc=tab(ntb,1) if (.not. (aircraft_t_bc .and. acft_profl_file)) then if (l4dvar.or.l4densvar) then if ((t4dvwinlen) .and. .not.driftl) cycle loop_readsb ! outside time window @@ -1186,7 +1237,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& enddo do k=1,levs ppb=obsdat(1,k) - cat=idnint(min(obsdat(10,k),qcmark_huge)) + cat=nint(min(obsdat(10,k),qcmark_huge)) if ( cat /=0 ) cycle ppb=max(zero,min(ppb,r2000)) if(ppb>=etabl_ps(itypex,1,1)) k1_ps=1 @@ -1209,12 +1260,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& obserr(1,k)=max(obserr(1,k),perrmin) endif ! Surface pressure b - var_jb(1,k)=(one-del_ps)*btabl_ps(itypex,k1_ps,ierr_ps)+del_ps*btabl_ps(itypex,k2_ps,ierr_ps) + var_jb(1,k)=(one-del_ps)*btabl_ps(itypex,k1_ps,ierr_ps)+del_ps*btabl_ps(itypex,k2_ps,ierr_ps) var_jb(1,k)=max(var_jb(1,k),pjbmin) if (var_jb(1,k) >=10.0_r_kind) var_jb(1,k)=zero enddo - endif - if (tob) then + else if (tob) then itypex=itypey ierr_t=0 do i =1,maxsub_t @@ -1264,8 +1314,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& var_jb(3,k)=max(var_jb(3,k),tjbmin) if (var_jb(3,k) >=10.0_r_kind) var_jb(3,k)=zero enddo - endif - if (qob) then + else if (qob) then itypex=itypey ierr_q=0 do i =1,maxsub_q @@ -1318,8 +1367,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! write(6,*) 'READ_PREPBUFR:120_q,obserr,var_jb=',obserr(2,k),var_jb(2,k),ppb ! endif enddo - endif - if (uvob) then + else if (uvob) then itypex=itypey ierr_uv=0 do i =1,maxsub_uv @@ -1355,13 +1403,13 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (abs(ediff_uv) > tiny_r_kind) then del_uv = (ppb-etabl_uv(itypex,k1_uv,1))/ediff_uv else - del_uv = huge_r_kind + del_uv = huge_r_kind endif del_uv=max(zero,min(del_uv,one)) ! Wind error ! write(6,*) 'READ_PREPBUFR_UV:',itypex,k1_uv,itypey,k2_uv,ierr_uv,nc,kx,ppb - obserr(5,k)=(one-del_uv)*etabl_uv(itypex,k1_uv,ierr_uv)+del_uv*etabl_uv(itypex,k2_uv,ierr_uv) - obserr(5,k)=max(obserr(5,k),werrmin) + obserr(5,k)=(one-del_uv)*etabl_uv(itypex,k1_uv,ierr_uv)+del_uv*etabl_uv(itypex,k2_uv,ierr_uv) + obserr(5,k)=max(obserr(5,k),werrmin) !Wind b var_jb(5,k)=(one-del_uv)*btabl_uv(itypex,k1_uv,ierr_uv)+del_uv*btabl_uv(itypex,k2_uv,ierr_uv) var_jb(5,k)=max(var_jb(5,k),wjbmin) @@ -1370,8 +1418,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! write(6,*) 'READ_PREPBUFR:220_uv,obserr,var_jb=',obserr(5,k),var_jb(5,k),ppb,k2_uv,del_uv ! endif enddo - endif - if (pwob) then + else if (pwob) then itypex=itypey ierr_pw=0 do i =1,maxsub_pw @@ -1615,11 +1662,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& plevs(k)=one_tenth*obsdat(1,k) ! convert mb to cb if (kx == 290) plevs(k)=101.0_r_kind ! Assume 1010 mb = 101.0 cb if (goesctpobs) plevs(k)=goescld(1,k)/1000.0_r_kind ! cloud top pressure in cb - pqm(k)=idnint(qcmark(1,k)) - qqm(k)=idnint(qcmark(2,k)) - tqm(k)=idnint(qcmark(3,k)) - wqm(k)=idnint(qcmark(5,k)) - pmq(k)=idnint(qcmark(8,k)) + pqm(k)=nint(qcmark(1,k)) + qqm(k)=nint(qcmark(2,k)) + tqm(k)=nint(qcmark(3,k)) + wqm(k)=nint(qcmark(5,k)) + pmq(k)=nint(qcmark(8,k)) end do ! 181, 183, 187, and 188 are the screen-level obs over land @@ -1649,14 +1696,14 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (tpc(k,j)==glcd) then !found GLERL ob - use that and jump out of events stack obsdat(3,k)=tobaux(1,k,j) qcmark(3,k)=min(tobaux(2,k,j),qcmark_huge) - tqm(k)=idnint(qcmark(3,k)) + tqm(k)=nint(qcmark(3,k)) exit end if end if if (tpc(k,j)==vtcd) then obsdat(3,k)=tobaux(1,k,j+1) qcmark(3,k)=min(tobaux(2,k,j+1),qcmark_huge) - tqm(k)=idnint(qcmark(3,k)) + tqm(k)=nint(qcmark(3,k)) end if if (tpc(k,j)>=bmiss) exit ! end of stack end do @@ -1714,16 +1761,14 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& endif end if LOOP_K_LEVS: do k=1,levs - if( zflag ==-1) then - ppb=obsdat(1,k)*one_tenth - else if(zflag ==1) then - ppb=obsdat(4,k) - endif - if(kx==224 .and. newvad)then - if(mod(k,6)/=0) cycle LOOP_K_LEVS - end if - - icntpnt=icntpnt+1 + if( zflag ==-1) then + ppb=obsdat(1,k)*one_tenth + else if(zflag ==1) then + ppb=obsdat(4,k) + endif + if(kx==224 .and. newvad)then + if(mod(k,6)/=0) cycle LOOP_K_LEVS + end if ! Extract quality marks if(tob)then @@ -1738,11 +1783,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(obsdat(2,k) > r0_01_bmiss)cycle loop_k_levs qm=qqm(k) else if(pwob) then - pwq=idnint(qcmark(7,k)) + pwq=nint(qcmark(7,k)) qm=pwq else if(sstob) then sstq=100 - if (k==1) sstq=idnint(min(sstdat(4,k),qcmark_huge)) + if (k==1) sstq=nint(min(sstdat(4,k),qcmark_huge)) qm=sstq else if(gustob) then gustqm=0 @@ -1798,10 +1843,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if if (psob) then - cat=idnint(min(obsdat(10,k),qcmark_huge)) + cat=nint(min(obsdat(10,k),qcmark_huge)) if ( cat /=0 ) cycle loop_k_levs if ( obsdat(1,k)< r500) qm=100 - zqm=idnint(qcmark(4,k)) + zqm=nint(qcmark(4,k)) if (zqm>=lim_zqm .and. zqm/=15 .and. zqm/=9) qm=9 endif @@ -1811,7 +1856,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! extract aircraft profile information if (aircraft_t_bc .and. acft_profl_file) then - if (idnint(obsdat(10,k))==7) cycle LOOP_K_LEVS + if (nint(obsdat(10,k))==7) cycle LOOP_K_LEVS if(abs(hdr3(2,k))>r90 .or. abs(hdr3(1,k))>r360) cycle LOOP_K_LEVS if(hdr3(1,k)== r360)hdr3(1,k)=hdr3(1,k)-r360 if(hdr3(1,k) < zero)hdr3(1,k)=hdr3(1,k)+r360 @@ -1949,19 +1994,23 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& endif ! Set usage variable usage = zero - if(icuse(nc) <= 0)usage=100._r_kind - if(qm == 15 .or. qm == 12 .or. qm == 9)usage=100._r_kind - if(qm >=lim_qm )usage=101._r_kind - if(convobs .and. pqm(k) >=lim_qm )usage=102._r_kind - if((kx>=192.and.kx<=195) .and. psob )usage=r100 - if (gustob .and. obsdat(8,k) > r0_1_bmiss) usage=103._r_kind - if (visob .and. obsdat(9,k) > r0_1_bmiss) usage=103._r_kind - if (tdob .and. obsdat(12,k) > r0_1_bmiss) usage=103._r_kind - if (pmob .and. obsdat(13,k) > r0_1_bmiss) usage=103._r_kind - if (mxtmob .and. maxtmint(1,k) > r0_1_bmiss) usage=103._r_kind - if (mitmob .and. maxtmint(2,k) > r0_1_bmiss) usage=103._r_kind - if (howvob .and. owave(1,k) > r0_1_bmiss) usage=103._r_kind - if (cldchob .and. cldceilh(1,k) > r0_1_bmiss) usage=103._r_kind + if((gustob .and. obsdat(8,k) > r0_1_bmiss) .or. & + (visob .and. obsdat(9,k) > r0_1_bmiss) .or. & + (tdob .and. obsdat(12,k) > r0_1_bmiss) .or. & + (pmob .and. obsdat(13,k) > r0_1_bmiss) .or. & + (mxtmob .and. maxtmint(1,k) > r0_1_bmiss) .or. & + (mitmob .and. maxtmint(2,k) > r0_1_bmiss) .or. & + (howvob .and. owave(1,k) > r0_1_bmiss) .or. & + (cldchob .and. cldceilh(1,k) > r0_1_bmiss))then + usage=103._r_kind + else if(convobs .and. pqm(k) >=lim_qm )then + usage=102._r_kind + else if(qm >=min(lim_qm,8) )then + usage=101._r_kind + else if(icuse(nc) <= 0 .or. & + (kx>=192 .and. kx<=195 .and. psob))then + usage=100._r_kind + end if if (sfctype) then if (i_gsdsfc_uselist==1 ) then @@ -1976,18 +2025,18 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& !retrieve wind sensor height if (twodvar_regional) then if ( kx==288.or.kx==295 .or. (gustob .and. (kx==188.or.kx==195)) ) then - call find_wind_height(c_prvstg,c_sprvstg,windsensht) + call find_wind_height(c_prvstg,c_sprvstg,windsensht,kcount) endif endif - endif - if (sfctype .and. i_gsdqc==2) then ! filter bad 2-m dew point and 0 mesonet wind obs - if (kx==288.or.kx==295) then ! for mesonet wind - if(abs(obsdat(5,k))<0.01_r_kind .and. abs(obsdat(6,k))<0.01_r_kind) usage=115._r_kind - endif - if (qob .and. (kx >=180 .and. kx<=189) .and. obsdat(2,k) < 1.0e10_r_kind) then ! for 2-m dew point - if(obsdat(12,k) < min(-40.0_r_kind,obsdat(3,k)-10.0_r_kind)) usage=116._r_kind ! < min(-40C or T-Td) - if((obsdat(3,k)-obsdat(12,k)) > 70.0_r_kind) usage=117._r_kind ! <70C - if(obsdat(12,k) > 32.2_r_kind) usage=118._r_kind ! > 90F + if(i_gsdqc==2) then ! filter bad 2-m dew point and 0 mesonet wind obs + if (kx==288.or.kx==295) then ! for mesonet wind + if(abs(obsdat(5,k))<0.01_r_kind .and. abs(obsdat(6,k))<0.01_r_kind) usage=115._r_kind + endif + if (qob .and. (kx >=180 .and. kx<=189) .and. obsdat(2,k) < 1.0e10_r_kind) then ! for 2-m dew point + if(obsdat(12,k) < min(-40.0_r_kind,obsdat(3,k)-10.0_r_kind)) usage=116._r_kind ! < min(-40C or T-Td) + if((obsdat(3,k)-obsdat(12,k)) > 70.0_r_kind) usage=117._r_kind ! <70C + if(obsdat(12,k) > 32.2_r_kind) usage=118._r_kind ! > 90F + endif endif endif ! to-do: should we add qob checks from above for landsfctype too? @@ -2092,10 +2141,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Get information from surface file necessary for conventional data here + if(icuse(nc) < 0)qm = 9 ! Special block for data thinning - if requested if (ithin > 0 .and. ithin <5 .and. usage <100.0_r_kind) then ! if (ithin > 0 .and. ithin <5) then - ntmp=ndata ! counting moved to map3gridS ! Set data quality index for thinning if (thin4d) then @@ -2118,46 +2167,27 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (ptime >zero ) then itime=int((abs(timedif)+three)/ptime)+1 - if(itime >ntime) itime=ntime - call map3grids_tm(zflag,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - ppb,itime,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) - if (.not. luse) then - if(k==levs) then - cycle loop_readsb - else - cycle LOOP_K_LEVS - endif - endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - if(uvob)nodata=nodata+1 - endif - isort(icntpnt)=iout + if(itime >ntime) itime=ntime + call map3grids_m_tm(zflag,save_all,pflag,presl_thin,nlevp, & + dlat_earth,dlon_earth,ppb,itime,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) else - call map3grids(zflag,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - ppb,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) - if (.not. luse) then - if(k==levs) then - cycle loop_readsb - else - cycle LOOP_K_LEVS - endif - endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - if(uvob)nodata=nodata+1 + call map3grids_m(zflag,save_all,pflag,presl_thin,nlevp, & + dlat_earth,dlon_earth,ppb,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) + endif + if (.not. luse) then + if(k==levs) then + cycle loop_readsb + else + cycle LOOP_K_LEVS endif - isort(icntpnt)=iout endif + if(rthin(ndata))usage=101._r_kind else ndata=ndata+1 - nodata=nodata+1 - if(uvob)nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout endif + iout=ndata if(ndata > maxobs) then write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype @@ -2175,6 +2205,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& dlnpob=log(plevs(k)) ! ln(pressure in cb) + if(qm >= 8 .or. usage >= 100.0_r_kind)then + rusage(iout)=.false. + end if ! Temperature if(tob) then ppb=obsdat(1,k) @@ -2819,7 +2852,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& hig_cldamt,hig_cldamt_qc,tcamt,lcbas,tcamt_qc,lcbas_qc,ceiling,stnelev) end if - if(tcamt_qc==15 .or. tcamt_qc==12 .or. tcamt_qc==9) usage=100._r_kind tcamt_oe=20.0_r_kind if(tcamt_qc==1) tcamt_oe=tcamt_oe*1.25_r_kind if(tcamt_qc==2) tcamt_oe=tcamt_oe*1.50_r_kind @@ -2856,7 +2888,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& low_cldamt,low_cldamt_qc,mid_cldamt,mid_cldamt_qc, & hig_cldamt,hig_cldamt_qc,tcamt,lcbas,tcamt_qc,lcbas_qc,ceiling,stnelev) - if(lcbas_qc==15 .or. lcbas_qc==12 .or. lcbas_qc==9) usage=100._r_kind + if(lcbas_qc >= 8) usage=100._r_kind + if(usage >= 100.0_r_kind)rusage(iout)=.false. lcbas_oe=4500.0_r_kind if(lcbas_qc==3) lcbas_oe=lcbas_oe*1.25_r_kind if(lcbas_qc==4) lcbas_oe=lcbas_oe*1.5_r_kind @@ -2963,51 +2996,82 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& deallocate(presl_thin) call del3grids endif - if (.not.use_all_tm) then - deallocate(presl_thin) + if(.not.use_all_tm) then + deallocate(presl_thin) call del3grids_tm endif - ! Normal exit enddo loop_convinfo! loops over convinfo entry matches deallocate(lmsg,tab,nrep) + ! Close unit to bufr file call closbf(lunin) close(lunin) ! Apply hilbert curve for cross validation if requested - if(lhilbert) & - call apply_hilbertcurve(maxobs,obstype,cdata_all(thisobtype_usage,1:maxobs)) + if(lhilbert) then + call apply_hilbertcurve(ndata,obstype,cdata_all(thisobtype_usage,1:ndata)) -! Write header record and data to output file for further processing - allocate(iloc(ndata)) - icount=0 - do i=1,maxobs - if(isort(i) > 0)then - icount=icount+1 - iloc(icount)=isort(i) - end if - end do - if(ndata /= icount)then - write(6,*) ' PREPBUFR: mix up in read_prepbufr ,ndata,icount ',ndata,icount - call stop2(50) + do i=1,ndata + if(cdata_all(thisobtype_usage,i) >= 100._r_kind) rusage(i) = .false. + end do end if - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - itx=iloc(i) - do k=1,nreal - cdata_out(k,i)=cdata_all(k,itx) + + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,maxobs +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' prep ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin +! If thinned data set quality mark to 14 + ! If flag to not save thinned data is set - compress data + do i=1,nxdata + ! pmot=0 - all obs - thin obs + ! pmot=1 - all obs + ! pmot=2 - use obs + ! pmot=3 - use obs + thin obs + + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 1) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + if(rthin(i) .and. iqm > 0)cdata_all(iqm,i)=14 + if(.not. rusage(i))cdata_all(iuse,i) = max(cdata_all(iuse,i),101.0_r_kind) + ndata=ndata+1 + if(i > ndata)then + do k=1,nreal + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end if end do - end do - deallocate(iloc,isort,cdata_all) + if(uvob)then + nodata=nodata+2*ndata + else + nodata=nodata+ndata + end if + end if + deallocate(rusage,rthin) + ! the following is gettin the types which will be applied hilbert curve to ! estimate the density - if(obstype == 'uv') then + if(obstype == 'uv' .and. ndata > 0) then vmin=-10.00_r_kind vmax=18000.00_r_kind nor=0 @@ -3084,7 +3148,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& endif enddo - write(6,*),'READ_PREPBUFR:dentrip,pmesh,rmesh,ndata=',dentrip,pmesh,rmesh,ntime_max,ndata + write(6,*),'READ_PREPBUFR: itype,dentrip,pmesh,rmesh,ndata=',& + itype,dentrip,pmesh,rmesh,ntime_max,ndata if(dentrip >= one .and. pmesh >zero .and. rmesh >zero) then allocate(data_hilb(3,ndata,6),index_arr(ndata,ntime_max)) @@ -3094,25 +3159,25 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& index_arr=0 do k=1,ndata - ikx=nint(cdata_out(10,k)) + ikx=nint(cdata_all(10,k)) 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)) + prest=r10*exp(cdata_all(4,k)) if (prest <100.0_r_kind) cycle if(ithin_conv(ikx) >=5) then if(ptime_conv(ikx) >zero) then - ntime=int(((cdata_out(9,k)-time_offset)+three)/ptime_conv(ikx))+1 + ntime=int(((cdata_all(9,k)-time_offset)+three)/ptime_conv(ikx))+1 endif if(ntime >ntime_max) ntime=ntime_max if(ntime <0) ntime=1 ntype_arr(ntime)=ntype_arr(ntime)+1 ndata_hil=ntype_arr(ntime) - data_hilb(1,ndata_hil,ntime)=cdata_out(20,k) - data_hilb(2,ndata_hil,ntime)=cdata_out(19,k) + data_hilb(1,ndata_hil,ntime)=cdata_all(20,k) + data_hilb(2,ndata_hil,ntime)=cdata_all(19,k) prest=prest*100.0_r_kind if(prest >stndrd_atmos_ps) then prest=zero @@ -3130,7 +3195,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& write(6,*),'READ_PREPBUFR :something is wrong,lat,lon,prest=',& data_hilb(1,ndata_hil,ntime),& data_hilb(2,ndata_hil,ntime),& - cdata_out(4,k),data_hilb(3,ndata_hil,ntime) + cdata_all(4,k),data_hilb(3,ndata_hil,ntime) endif endif endif @@ -3152,12 +3217,12 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ndata_hil=0 deallocate(rlat_hil,rlon_hil,height,wtob) endif - enddo + enddo deallocate(data_hilb,index_arr) endif do i=1,ndata - cdata_out(26,i)=wght_hilb(i) + cdata_all(26,i)=wght_hilb(i) enddo deallocate(wght_hilb) @@ -3172,26 +3237,24 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(metarcldobs .and. ndata > 0) then if(i_ens_mean /= 1) then maxobs=2000000 - allocate(cdata_all(nreal,maxobs)) - call reorg_metar_cloud(cdata_out,nreal,ndata,cdata_all,maxobs,iout) + allocate(cdata_out(nreal,maxobs)) + call reorg_metar_cloud(cdata_all,nreal,ndata,cdata_out,maxobs,iout) ndata=iout - deallocate(cdata_out) - allocate(cdata_out(nreal,ndata)) + deallocate(cdata_all) + allocate(cdata_all(nreal,ndata)) do i=1,nreal do j=1,ndata - cdata_out(i,j)=cdata_all(i,j) + cdata_all(i,j)=cdata_out(i,j) end do end do - deallocate(cdata_all) + deallocate(cdata_out) endif endif - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata - write(lunout) cdata_out - - + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) - deallocate(cdata_out) + deallocate(cdata_all) call destroy_rjlists call destroy_aircraft_rjlists if(i_gsdsfc_uselist==1) call destroy_gsd_sfcuselist @@ -3207,6 +3270,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& 'nvtest,vdisterrmax=',ntest,vdisterrmax if(print_verbose)write(6,*)'READ_PREPBUFR: closbf(',lunin,')' + if (twodvar_regional .and. (uvob .or. gustob .or. spdob)) then + write(6,*) 'kcount values from find wind height = ',kcount + end if + ! End of routine @@ -3277,7 +3344,7 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) enddo do k=1,levs - cat(k)=idnint(obsdat(10,k)) + cat(k)=nint(obsdat(10,k)) enddo @@ -3294,10 +3361,10 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) if(kx==120)then - pqm(1)=idnint(min(qcmark(1,1),10000.0)) - qqm(1)=idnint(min(qcmark(2,1),10000.0)) - tqm(1)=idnint(min(qcmark(3,1),10000.0)) - zqm(1)=idnint(min(qcmark(4,1),10000.0)) + pqm(1)=nint(min(qcmark(1,1),10000.0)) + qqm(1)=nint(min(qcmark(2,1),10000.0)) + tqm(1)=nint(min(qcmark(3,1),10000.0)) + zqm(1)=nint(min(qcmark(4,1),10000.0)) call grdcrd(dpres,levs,prsltmp(1),nsig,-1) do k=1,levs tvflg(k)=one ! initialize as sensible @@ -3309,10 +3376,10 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) do i=2,levs im=i-1 - pqm(i)=idnint(min(qcmark(1,i),10000.0)) - qqm(i)=idnint(min(qcmark(2,i),10000.0)) - tqm(i)=idnint(min(qcmark(3,i),10000.0)) - zqm(i)=idnint(min(qcmark(4,i),10000.0)) + pqm(i)=nint(min(qcmark(1,i),10000.0)) + qqm(i)=nint(min(qcmark(2,i),10000.0)) + tqm(i)=nint(min(qcmark(3,i),10000.0)) + zqm(i)=nint(min(qcmark(4,i),10000.0)) if ( (cat(i)==2 .or. cat(im)==2 .or. cat(i)==5 .or. cat(im)==5) .and. & pqm(i)<4 .and. pqm(im)<4 )then ku=dpres(i)-1 @@ -3325,8 +3392,8 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) write(6,*)'error in SONDE_EXT levs > 255' return endif - obsdat(1,ll)=dpmdl(k) - qcmark(1,ll) =max (qcmark(1,i),qcmark(1,im)) !PQM + obsdat(1,ll) = dpmdl(k) + qcmark(1,ll) = max (qcmark(1,i),qcmark(1,im)) !PQM qcmark(2,ll) = bmiss qcmark(3,ll) = bmiss qcmark(4,ll) = bmiss @@ -3339,21 +3406,21 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) wi=(dpobs(im)-prsltmp(k))/(dpobs(im)-dpobs(i)) !!! find tob, only bogus if both good obs and of the same type (sensible/virtual) if( tqm(i)<4 .and. tqm(im)<4 .and. tvflg(i)==tvflg(im) ) then - obsdat(3,ll)=obsdat(3,im)*wim + obsdat(3,i)*wi - drfdat(1,ll) = drfdat(1,im)*wim + drfdat(1,i)*wi - drfdat(2,ll) = drfdat(2,im)*wim + drfdat(2,i)*wi - drfdat(3,ll) = drfdat(3,im)*wim + drfdat(3,i)*wi - qcmark(3,ll) =max (qcmark(3,i),qcmark(3,im)) !TQM - obserr(3,ll) =max (obserr(3,i),obserr(3,im)) ! TOE + obsdat(3,ll) = obsdat(3,im)*wim + obsdat(3,i)*wi + drfdat(1,ll) = drfdat(1,im)*wim + drfdat(1,i)*wi + drfdat(2,ll) = drfdat(2,im)*wim + drfdat(2,i)*wi + drfdat(3,ll) = drfdat(3,im)*wim + drfdat(3,i)*wi + qcmark(3,ll) = max (qcmark(3,i),qcmark(3,im)) !TQM + obserr(3,ll) = max (obserr(3,i),obserr(3,im)) ! TOE endif !!! find qob if( qqm(i)<4 .and. qqm(im)<4 ) then - obsdat(2,ll)=obsdat(2,im)*wim + obsdat(2,i)*wi - drfdat(1,ll) = drfdat(1,im)*wim + drfdat(1,i)*wi - drfdat(2,ll) = drfdat(2,im)*wim + drfdat(2,i)*wi - drfdat(3,ll) = drfdat(3,im)*wim + drfdat(3,i)*wi - qcmark(2,ll) =max (qcmark(2,i),qcmark(2,im)) !QQM - obserr(2,ll) =max (obserr(2,i),obserr(2,im)) ! QOE + obsdat(2,ll) = obsdat(2,im)*wim + obsdat(2,i)*wi + drfdat(1,ll) = drfdat(1,im)*wim + drfdat(1,i)*wi + drfdat(2,ll) = drfdat(2,im)*wim + drfdat(2,i)*wi + drfdat(3,ll) = drfdat(3,im)*wim + drfdat(3,i)*wi + qcmark(2,ll) = max (qcmark(2,i),qcmark(2,im)) !QQM + obserr(2,ll) = max (obserr(2,i),obserr(2,im)) ! QOE endif !!! define zob if( zqm(i)<4 .and. zqm(im)<4 ) then @@ -3368,14 +3435,14 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) enddo !levs !!!!!!!!! w (not used) !!!!!!!!!!!!!!!!!!!!!!!!!!! elseif(kx==220)then - pqm(1)=idnint(min(qcmark(1,1),10000.0)) - wqm(1)=idnint(min(qcmark(5,1),10000.0)) + pqm(1)=nint(min(qcmark(1,1),10000.0)) + wqm(1)=nint(min(qcmark(5,1),10000.0)) call grdcrd(dpres,levs,prsltmp(1),nsig,-1) do i=2,levs im=i-1 - wqm(i)=idnint(min(qcmark(5,i),10000.0)) - zqm(i)=idnint(min(qcmark(4,i),10000.0)) - pqm(i)=idnint(min(qcmark(1,i),10000.0)) + wqm(i)=nint(min(qcmark(5,i),10000.0)) + zqm(i)=nint(min(qcmark(4,i),10000.0)) + pqm(i)=nint(min(qcmark(1,i),10000.0)) if( wqm(i)<4 .and. wqm(im)<4 .and. pqm(i)<4 .and. pqm(im)<4 .and.& (cat(i)==2 .or. cat(im)==2 .or. cat(i)==5 .or. cat(im)==5) )then ku=dpres(i)-1 diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90 index 9ce156e736..5b1cffbf0c 100644 --- a/src/gsi/read_radar.f90 +++ b/src/gsi/read_radar.f90 @@ -90,16 +90,15 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu eccentricity,somigliana,grav_ratio,grav, & semi_major_axis,flattening,two use qcmod, only: erradar_inflate,vadfile,newvad - use obsmod, only: iadate,ianldate,l_foreaft_thin + use obsmod, only: iadate,ianldate,l_foreaft_thin,reduce_diag use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,nsig,& fv3_regional use gridmod, only: wrf_nmm_regional,nems_nmmb_regional,cmaq_regional,wrf_mass_regional use gridmod, only: fv3_regional use convinfo, only: nconvtype,ctwind, & - ncmiter,ncgroup,ncnumgrp,icuse,ictype,ioctype,ithin_conv,rmesh_conv,pmesh_conv - use convthin, only: make3grids,map3grids,del3grids,use_all - use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model + ncmiter,ncgroup,ncnumgrp,icuse,ictype,ioctype,ithin_conv,rmesh_conv,pmesh_conv,pmot_conv + use convthin, only: make3grids,map3grids_m,del3grids,use_all use mpimod, only: npe use gsi_io, only: verbose use mpimod, only: mype @@ -107,6 +106,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu use directDA_radaruse_mod, only: l_correct_azmu, l_correct_tilt, i_correct_tilt, & l_azm_east1st, l_plt_diag_rw use directDA_radaruse_mod, only: l_use_rw_columntilt + use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model implicit none @@ -154,7 +154,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu character(30) outmessage character(255) filename - integer(i_kind) lnbufr,i,j,k,maxobs,icntpnt,iiout,n,istop + integer(i_kind) lnbufr,i,j,k,maxobs,n,istop integer(i_kind) nmrecs,ibadazm,ibadtilt,ibadrange,ibadwnd,ibaddist,ibadheight,ibadvad,kthin integer(i_kind) iyr,imo,idy,ihr,imn,isc,ithin integer(i_kind) ibadstaheight,ibaderror,notgood,idate,iheightbelowsta,ibadfit @@ -269,9 +269,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu integer(i_kind) :: ii,jjj,nmissing,nirrr,noutside,ntimeout,nsubzero,iimax integer(i_kind) ntdrvr_in,ntdrvr_kept,ntdrvr_thin1,ntdrvr_thin2 integer(i_kind) ntdrvr_thin2_foreswp,ntdrvr_thin2_aftswp - integer(i_kind) maxout,maxdata integer(i_kind) kk,klon1,klat1,klonp1,klatp1 - integer(i_kind),allocatable,dimension(:):: isort real(r_single) elevmax,elevmin real(r_single) thisrange,thisazimuth,thistilt @@ -286,7 +284,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu real(r_kind),dimension(nsig):: zges,hges real(r_kind) dx,dy,dx1,dy1,w00,w10,w01,w11 logical luse - integer(i_kind) ntmp,iout + integer(i_kind) iout integer(i_kind):: zflag integer(i_kind) nlevz ! vertical level for thinning real(r_kind) crit1,timedif @@ -298,6 +296,11 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu real(r_kind) tdrele1,tdrele2,tdrele3 integer(i_kind) nswp,firstbeam,nforeswp,naftswp,nfore,naft,nswptype,irec logical foreswp,aftswp + + logical, allocatable,dimension(:) :: rusage,rthin + logical save_all +! integer(i_kind) numthin,numqc,numrem + integer(i_kind) nxdata,pmot,numall data lnbufr/10/ data hdrstr(1) / 'CLAT CLON SELV ANEL YEAR MNTH DAYS HOUR MINU MGPT' / @@ -357,10 +360,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu hdrstr(2)='PTID YEAR MNTH DAYS HOUR MINU SECO CLAT CLON FLVLST ANAZ ANEL' end if - allocate(cdata_all(maxdat,maxobs),isort(maxobs)) + allocate(cdata_all(maxdat,maxobs),rusage(maxobs),rthin(maxobs)) - isort = 0 - cdata_all=zero + rusage=.true. + rthin=.false. if (trim(infile) /= 'tldplrbufr' .and. trim(infile) /= 'tldplrso') then @@ -633,17 +636,25 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu nsuper2_kept=0 ! LEVEL_TWO_READ: if(loop==0 .and. sis=='l2rw') then - if(loop==0) outmessage='level 2 superobs:' + if(loop==0) outmessage='level 2 superobs:' ! Open sequential file containing superobs open(lnbufr,file='radar_supobs_from_level2',form='unformatted') rewind lnbufr + pmot=0 + if(ikx /= 0)then + pmot=pmot_conv(ikx) + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all = .false. + if(pmot /= 2 .and. pmot /= 0)save_all=.true. + end if ! dist2max=-huge(dist2max) ! dist2min=huge(dist2min) ! Loop to read superobs data file - do + superobs:do + if(ikx == 0) exit superobs read(lnbufr,iostat=iret)this_staid,this_stalat,this_stalon,this_stahgt, & thistime,thislat,thislon,thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt if(iret/=0) exit @@ -845,13 +856,14 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu level2(ivad)=level2(ivad)+1 nobs_box(irrr,iaaa,ivadz,ivad)=nobs_box(irrr,iaaa,ivadz,ivad)+1 ndata =min(ndata+1,maxobs) - nodata =min(nodata+1,maxobs) !number of obs not used (no meaning here) + nodata =min(nodata+1,maxobs) usage = zero if(icuse(ikx) < 0)usage=r100 if(ncnumgrp(ikx) > 0 )then ! cross validation on if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) end if - + if(usage >= 100._r_kind) rusage(ndata)=.false. + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) LEVEL_TWO_READ: if(loop==0 .and. sis=='l2rw') then @@ -892,7 +904,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu notgood = notgood + 1 end if - end do + end do superobs close(lnbufr) ! A simple unformatted fortran file should not be mixed with a bufr I/O @@ -1087,6 +1099,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu if(trim(ioctype(i)) == trim(obstype))ikx = i end do if(ikx==0) cycle loop2 + pmot=pmot_conv(ikx) + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all = .false. + if(pmot /= 2 .and. pmot /= 0)save_all=.true. call w3fs21(idate5,minobs) t4dv=real(minobs-iwinbgn,r_kind)*r60inv if (l4dvar.or.l4densvar) then @@ -1275,12 +1291,13 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu end if nobs_box(irrr,iaaa,ivadz,ivad)=nobs_box(irrr,iaaa,ivadz,ivad)+1 ndata = min(ndata+1,maxobs) - nodata = min(nodata+1,maxobs) !number of obs not used (no meaning here) + nodata = min(nodata+1,maxobs) usage = zero if(icuse(ikx) < 0)usage=r100 if(ncnumgrp(ikx) > 0 )then ! cross validation on if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) end if + if(usage >= 100._r_kind) rusage(ndata)=.false. call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) @@ -1325,7 +1342,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu ! End of bufr read loop end do loop2 end if - + ! Normal exit ! Close unit to bufr file @@ -1335,8 +1352,8 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2.5/3 superob radar file.' - if(loop==1) write(6,*)'READ_RADAR: nsuper2_5_in,nsuper2_5_kept=',nsuper2_5_in,nsuper2_5_kept - if(loop==2) write(6,*)'READ_RADAR: nsuper3_in,nsuper3_kept=',nsuper3_in,nsuper3_kept + if(loop==1)write(6,*)'READ_RADAR: nsuper2_5_in,nsuper2_5_kept=',nsuper2_5_in,nsuper2_5_kept + if(loop==2)write(6,*)'READ_RADAR: nsuper3_in,nsuper3_kept=',nsuper3_in,nsuper3_kept write(6,*)'READ_RADAR: # no vad match =',novadmatch write(6,*)'READ_RADAR: # out of vadrange=',ioutofvadrange write(6,*)'READ_RADAR: # bad azimuths=',ibadazm @@ -1586,6 +1603,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu if(trim(ioctype(i)) == trim(obstype))ikx = i end do if(ikx==0) cycle sb_report + pmot=pmot_conv(ikx) + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all = .false. + if(pmot /= 2 .and. pmot /= 0)save_all=.true. ! time window check call w3fs21(idate5,minobs) @@ -1957,9 +1978,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu re-compile GSI, re-run !!! <-- WARNING*** ***' end if ndata = min(ndata+1,maxobs) - nodata = min(nodata+1,maxobs) !number of obs not used (no meaning here) + nodata = min(nodata+1,maxobs) usage = zero if(icuse(ikx) < 0)usage=r100 + if(usage >= 100._r_kind) rusage(ndata)=.false. call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) @@ -2161,11 +2183,8 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu ntdrvr_thin2=0 ntdrvr_thin2_foreswp=0 ntdrvr_thin2_aftswp=0 - maxout=0 - maxdata=0 nmissing=0 subset_check(3)='NC006070' - icntpnt=0 nswp=0 nforeswp=0 naftswp=0 @@ -2195,6 +2214,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu zflag=0 nlevz=nsig endif + xmesh=rmesh call make3grids(xmesh,nlevz) allocate(zl_thin(nlevz)) @@ -2219,6 +2239,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu if(trim(ioctype(i)) == trim(obstype))ikx = i end do if(ikx == 0) return + pmot=pmot_conv(ikx) + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all = .false. + if(pmot /= 2 .and. pmot /= 0)save_all=.true. call w3fs21(iadate,mincy) ! analysis time in minutes @@ -2390,8 +2414,6 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu ntdrvr_kept=ntdrvr_kept+1 !#################### Data thinning ################### - icntpnt=icntpnt+1 - if(ithin > 0)then if(zflag == 0)then klon1= int(dlon); klat1= int(dlat) @@ -2423,7 +2445,6 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu zobs = height - ntmp=ndata ! counting moved to map3gridS if (thin4d) then timedif = zero else @@ -2431,27 +2452,19 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu endif crit1 = timedif/r6+half - call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,& - zobs,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) - maxout=max(maxout,iout) - maxdata=max(maxdata,ndata) + call map3grids_m(1,save_all,zflag,zl_thin,nlevz, & + dlat_earth,dlon_earth,zobs,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) if (.not. luse) then ntdrvr_thin2=ntdrvr_thin2+1 cycle endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(icntpnt)=iout else ndata =ndata+1 - nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout endif + iout=ndata if(ndata > maxobs) then write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype @@ -2465,9 +2478,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu if(ncnumgrp(ikx) > 0 )then ! cross validation on if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) end if + if(usage >= 100._r_kind) rusage(ndata)=.false. call deter_zsfc_model(dlat,dlon,zsges) - + ! Get information from surface file necessary for conventional data here call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) @@ -2659,6 +2673,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu if(trim(ioctype(i)) == trim(obstype) .and. kx == ictype(i))ikx = i end do if(ikx == 0) cycle loop4 + pmot=pmot_conv(ikx) + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. call w3fs21(idate5,minobs) t4dv=real(minobs-iwinbgn,r_kind)*r60inv @@ -2784,8 +2802,9 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu nread=nread+1 ! Select data every 3 km along each beam if(MOD(INT(tdr_obs(1,k)-tdr_obs(1,1)),3000) < 100)then - if(tdr_obs(3,k) >= 800.) nmissing=nmissing+1 !xx - if(tdr_obs(3,k) < 800.) then + if(tdr_obs(3,k) >= 800.) then + nmissing=nmissing+1 !xx + else ii=ii+1 dopbin(ii)=tdr_obs(3,k) thisrange=tdr_obs(1,k) @@ -2902,6 +2921,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu good=.true. if(.not.good0) then notgood0=notgood0+1 + good=.false. cycle end if ! if data is good, load into output array @@ -2910,8 +2930,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu ntdrvr_kept=ntdrvr_kept+1 !#################### Data thinning ################### - icntpnt=icntpnt+1 - if(icntpnt>maxobs) exit + if(ndata>maxobs) exit if(ithin > 0)then if(zflag == 0)then @@ -2944,7 +2963,6 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu zobs = height - ntmp=ndata ! counting moved to map3gridS if (thin4d) then timedif = zero else @@ -2952,10 +2970,9 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu endif crit1 = timedif/r6+half - call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,& - zobs,crit1,ndata,iout,icntpnt,iiout,luse,foreswp,aftswp) - maxout=max(maxout,iout) - maxdata=max(maxdata,ndata) + call map3grids_m(1,save_all,zflag,zl_thin,nlevz, & + dlat_earth,dlon_earth,zobs,crit1,ndata,& + luse,maxobs,rthin,foreswp,aftswp) if (.not. luse) then if (foreswp) then @@ -2966,18 +2983,11 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu ntdrvr_thin2=ntdrvr_thin2+1 cycle endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(icntpnt)=iout else ndata =ndata+1 - nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout endif + iout=ndata if(ndata > maxobs) then write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype @@ -2991,7 +3001,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu if(ncnumgrp(ikx) > 0 )then ! cross validation on if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) end if - + if(usage >= 100._r_kind) rusage(ndata)=.false. call deter_zsfc_model(dlat,dlon,zsges) ! Get information from surface file necessary for conventional data here @@ -3014,12 +3024,12 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu cdata(14)= skint ! skin temperature cdata(15)= ff10 ! 10 meter wind factor cdata(16)= sfcr ! surface roughness - cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) - cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) - cdata(19)=dist ! range from radar in km (used to estimate beam spread) - cdata(20)=zsges ! model elevation at radar site - cdata(21)=thiserr - cdata(22)=hdr(1)+three+one ! tail Doppler radar + cdata(17)= dlon_earth_deg ! earth relative longitude (degrees) + cdata(18)= dlat_earth_deg ! earth relative latitude (degrees) + cdata(19)= dist ! range from radar in km (used to estimate beam spread) + cdata(20)= zsges ! model elevation at radar site + cdata(21)= thiserr + cdata(22)= hdr(1)+three+one ! tail Doppler radar do j=1,maxdat cdata_all(j,iout)=cdata(j) end do @@ -3054,6 +3064,50 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu call del3grids endif + + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' radar1 ',trim(ioctype(ikx)),ikx,numall,& +! numrem,numqc,numthin,pmot + +! If flag to not save thinned data is set - compress data + do i=1,nxdata + + +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 1) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + if(rthin(i))cdata_all(12,i)=101._r_kind + ndata=ndata+1 + do k=1,maxdat + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end do + end if + nodata=nodata+ndata + deallocate(rusage,rthin) + + write(6,*)'READ_RADAR: # records saved in radar1 = ', ndata write(6,*)'READ_RADAR: # records(beams) read in nmrecs=', nmrecs write(6,*)'READ_RADAR: # records out of time window =', ntimeout write(6,*)'READ_RADAR: # records with bad tilt=',ibadtilt @@ -3225,9 +3279,10 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) use gsi_4dvar, only: l4dvar,l4densvar,winlen,time_4dvar use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,& fv3_regional - use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype - use deter_sfc_mod, only: deter_sfc2 + use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype,pmot_conv + use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model use mpimod, only: npe + use obsmod, only: reduce_diag implicit none @@ -3296,8 +3351,11 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) real(r_kind) thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt integer(i_kind) nsuper2_in,nsuper2_kept real(r_kind) errzmax + logical, allocatable,dimension(:) :: rusage + integer(i_kind) numqc,numrem + integer(i_kind) nxdata,pmot,numall + logical save_all - integer(i_kind),allocatable,dimension(:):: isort ! following variables are for fore/aft separation integer(i_kind) irec @@ -3319,11 +3377,9 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) dlatmin=huge(dlatmin) dlonmin=huge(dlonmin) - allocate(cdata_all(maxdat,maxobs),isort(maxobs)) - - isort = 0 - cdata_all=zero + allocate(cdata_all(maxdat,maxobs),rusage(maxobs)) + rusage=.true. ! Initialize variables xscale=1000._r_kind xscalei=one/xscale @@ -3337,13 +3393,17 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) errzmax=zero - ! First process any level 2 superobs. ! Initialize variables. ikx=0 do i=1,nconvtype if(trim(ioctype(i)) == trim(obstype))ikx = i end do + if(ikx == 0) return + pmot=pmot_conv(ikx) + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. timemax=-huge(timemax) timemin=huge(timemin) @@ -3509,22 +3569,22 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) end if good=.true. if(.not.good0) then + good=.false. notgood0=notgood0+1 cycle - else - end if ! If data is good, load into output array if(good) then nsuper2_kept=nsuper2_kept+1 ndata =min(ndata+1,maxobs) - nodata =min(nodata+1,maxobs) !number of obs not used (no meaninghere) + nodata =min(nodata+1,maxobs) usage = zero if(icuse(ikx) < 0)usage=r100 if(ncnumgrp(ikx) > 0 )then ! cross validation on if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) end if + if(usage >= 100._r_kind)rusage(ndata)=.true. call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) @@ -3560,8 +3620,46 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) end if end do + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' radar3 ',numall,numrem,numqc +! If flag to not save thinned data is set - compress data + if(pmot /= 1)then + do i=1,nxdata + +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if( pmot == 0 .or. & + (pmot == 2 .and. rusage(i)) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + if(i > ndata)then + do k=1,maxdat + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end if + end do + end if + end if + nodata=nodata+ndata + close(lnbufr) ! A simple unformatted fortran file should not be mixed with bufr I/O + write(6,*)'READ_RADAR_L2RW_NOVADQC: ',trim(outmessage),' reached eof on 2 superob radar file' write(6,*)'READ_RADAR_L2RW_NOVADQC: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad azimuths=',ibadazm @@ -3584,7 +3682,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) - deallocate(cdata_all) + deallocate(cdata_all,rusage) return @@ -3598,15 +3696,15 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) use oneobmod, only: oneobtest,learthrel_rw use gsi_4dvar, only: l4dvar,l4densvar,winlen,time_4dvar use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,nsig - use obsmod, only: doradaroneob,oneobradid,time_offset + use obsmod, only: doradaroneob,oneobradid,time_offset,reduce_diag use mpeu_util, only: gettablesize,gettable use convinfo, only: nconvtype,icuse,ioctype - use deter_sfc_mod, only: deter_sfc2 use mpimod, only: npe - use read_l2bufr_mod, only: radar_sites,radar_rmesh,radar_zmesh,elev_angle_max,del_time,range_max + use read_l2bufr_mod, only: radar_sites,radar_rmesh,radar_zmesh,elev_angle_max,del_time,range_max,radar_pmot use constants, only: eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening,grav_equator use obsmod,only: radar_no_thinning,iadate - use convthin, only: make3grids,map3grids + use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model + use convthin, only: make3grids,map3grids_m implicit none @@ -3646,7 +3744,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) integer(i_kind) iret,kx0 integer(i_kind) nreal,nchanl,ilat,ilon,ikx integer(i_kind) idomsfc - real(r_kind) usage,ff10,sfcr,skint,t4dvo,toff + real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff real(r_kind) eradkm,dlat_earth,dlon_earth real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist @@ -3687,7 +3785,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) character(4),allocatable,dimension(:):: rsite integer(i_kind),allocatable,dimension(:):: ruse character(8) chdr2,subset - real(r_double) rdisttest(n_gates_max),hdr(10),hdr2(12),rwnd0(3,n_gates_max) + real(r_double) rdisttest(n_gates_max),hdr(3),hdr2(12),rwnd0(3,n_gates_max) character(4) stn_id equivalence (chdr2,hdr2(1)) real(r_kind) stn_lat,stn_lon,stn_hgt,stn_az,stn_el,t,range,vrmax,vrmin,aactual,a43,b,c,selev0,celev0,thistiltr,epsh,h,ha,rlonloc,rlatloc @@ -3696,16 +3794,17 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) real(r_kind):: relm,srlm,crlm,sph,cph,cc,anum,denom real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11 real(r_kind), allocatable, dimension(:) :: zl_thin - integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1 + integer(i_kind) :: ithin,zflag,nlevz,klon1,klat1,kk,klatp1,klonp1 real(r_kind),dimension(nsig):: hges,zges real(r_kind) sin2,termg,termr,termrg,zobs - integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2 + integer(i_kind) iout,ntdrvr_thin2 real(r_kind) crit1,timedif - integer(i_kind) maxout,maxdata logical :: luse - integer(i_kind) iyref,imref,idref,ihref,nout - - integer(i_kind),allocatable,dimension(:):: isort + integer(i_kind) iyref,imref,idref,ihref,nout + logical, allocatable,dimension(:) :: rusage,rthin + logical save_all +! integer(i_kind) numthin,numqc,numrem + integer(i_kind) nxdata,pmot,numall ! following variables are for fore/aft separation integer(i_kind) irec @@ -3732,7 +3831,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) ilat=3 ikx=0 do j=1,nconvtype - if(trim(ioctype(j)) == trim(obstype))ikx = j + if(trim(ioctype(j)) == trim(obstype))ikx = j end do iaaamax=-huge(iaaamax) iaaamin=huge(iaaamin) @@ -3740,10 +3839,10 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) dlonmax=-huge(dlonmax) dlatmin=huge(dlatmin) dlonmin=huge(dlonmin) - allocate(cdata_all(maxdat,maxobs),isort(maxobs)) + allocate(cdata_all(maxdat,maxobs),rusage(maxobs),rthin(maxobs)) - isort = 0 - cdata_all=zero + rthin=.false. + rusage=.true. xscale=1000._r_kind xscalei=one/xscale max_rrr=nint(1000000.0_r_kind*xscalei) @@ -3752,7 +3851,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) nmrecs=0 irec=0 errzmax=zero - + timemax=-huge(timemax) timemin=huge(timemin) errmax=-huge(errmax) @@ -3774,16 +3873,16 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) nsuper2_in=0 nsuper2_kept=0 ntdrvr_thin2=0 - maxout=0 - maxdata=0 - isort=0 - icntpnt=0 nout=0 if(loop==0) outmessage='level 2 superobs:' rmesh=radar_rmesh zmesh=radar_zmesh nlevz=nint(16000._r_kind/zmesh) xmesh=rmesh + pmot=radar_pmot + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. call make3grids(xmesh,nlevz) allocate(zl_thin(nlevz)) zflag=1 @@ -3861,11 +3960,10 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) stn_lat=hdr2(2) stn_lon=hdr2(3) stn_hgt=hdr2(4)+hdr2(5) - call ufbint(inbufr,hdr,10,1,levs, & - 'SSTN YEAR MNTH DAYS HOUR MINU SECO ANAZ ANEL QCRW') + call ufbint(inbufr,hdr,3,1,levs,'ANAZ ANEL QCRW') nradials_in=nradials_in+1 - stn_az=r90-hdr(8) - stn_el=hdr(9) + stn_az=r90-hdr(1) + stn_el=hdr(2) call ufbint(inbufr,rwnd0,3,n_gates_max,n_gates,'DIST125M DMVR DVSW') do i=1,n_gates range=distfact*rwnd0(1,i) @@ -4031,8 +4129,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) azm=azm_earth end if !#################### Data thinning ################### - icntpnt=icntpnt+1 - if(icntpnt>maxobs) exit + if(ndata>maxobs) exit ithin=1 !number of obs to keep per grid box if(radar_no_thinning) then ithin=-1 @@ -4066,32 +4163,23 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) end do endif zobs = height - ntmp=ndata ! counting moved to map3gridS if (l4dvar) then timedif = zero else timedif=abs(t4dvo-toff) endif crit1 = timedif/r6+half - call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,& - zobs,crit1,ndata,iout,icntpnt,iiout,luse, .false., .false.) - maxout=max(maxout,iout) - maxdata=max(maxdata,ndata) + call map3grids_m(1,save_all,zflag,zl_thin,nlevz, & + dlat_earth,dlon_earth,zobs,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) if (.not. luse) then ntdrvr_thin2=ntdrvr_thin2+1 cycle endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(icntpnt)=iout else ndata =ndata+1 - nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout endif + iout=ndata !#################### Data thinning ################### if(.not. oneobtest) then iaaa=azm/(r360/(r8*irrr)) @@ -4139,7 +4227,14 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) if(good) then usage = zero - if(icuse(ikx) < 0)usage=r100 + if(icuse(ikx) < 0)then + rusage(ndata)=.false. + usage=r100 + end if + +! Get information from surface file necessary for conventional data here +! call deter_zsfc_model(dlat,dlon,zsges) +! call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) nsuper2_kept=nsuper2_kept+1 cdata(1) = error ! wind obs error (m/s) @@ -4174,23 +4269,68 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) end do end do close(lnbufr) ! A simple unformatted fortran file should not be mixed with bufr I/O - write(6,*)'READ_RADAR_L2RW_NOVADQC: ',trim(outmessage),' reached eof on 2 superob radar file' - write(6,*)'READ_RADAR_L2RW_NOVADQC: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept - write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad winds =',ibadwnd,nobs_badvr,nobs_badsr - write(6,*)'READ_RADAR_L2RW_NOVADQC: # num thinned =',kthin,ntdrvr_thin2 - write(6,*)'READ_RADAR_L2RW_NOVADQC: timemin,max =',timemin,timemax - write(6,*)'READ_RADAR_L2RW_NOVADQC: errmin,max =',errmin,errmax - write(6,*)'READ_RADAR_L2RW_NOVADQC: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' radar2 ',numall,numrem,numqc,numthin +! If thinned data set quality mark to 14 + if (ithin == 1 ) then + do i=1,nxdata + if(rthin(i))cdata_all(12,i)=101._r_kind + end do + end if + +! If flag to not save thinned data is set - compress data + if(pmot /= 1)then + do i=1,nxdata + +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + if(i > ndata)then + do k=1,maxdat + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end if + end do + end if + end if + nodata=nodata+ndata + write(6,*)'READ_RADAR_L2RW: ',trim(outmessage),' reached eof on 2 superob radar file' + write(6,*)'READ_RADAR_L2RW: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept + write(6,*)'READ_RADAR_L2RW: # bad winds =',ibadwnd,nobs_badvr,nobs_badsr + write(6,*)'READ_RADAR_L2RW: # num thinned =',kthin,ntdrvr_thin2 + write(6,*)'READ_RADAR_L2RW: timemin,max =',timemin,timemax + write(6,*)'READ_RADAR_L2RW: errmin,max =',errmin,errmax + write(6,*)'READ_RADAR_L2RW: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax ! Write observation to scratch file + deallocate(rusage,rthin) call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(6,*) shape(cdata_all) write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) deallocate(cdata_all) if (radar_sites) deallocate(rtable,rsite,ruse) deallocate(zl_thin) - deallocate(isort) return end subroutine read_radar_l2rw diff --git a/src/gsi/read_radar_wind_ascii.f90 b/src/gsi/read_radar_wind_ascii.f90 index 9d92699b6e..b79904273e 100644 --- a/src/gsi/read_radar_wind_ascii.f90 +++ b/src/gsi/read_radar_wind_ascii.f90 @@ -120,12 +120,12 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg use gridmod, only: regional,tll2xy,rotate_wind_ll2xy,nsig,nlat,nlon,& fv3_regional use obsmod, only: iadate, & - mintiltvr,maxtiltvr,minobrangevr,maxobrangevr, rmesh_vr,zmesh_vr,& + mintiltvr,maxtiltvr,minobrangevr,maxobrangevr,rmesh_vr,zmesh_vr,pmot_vr,& doradaroneob,oneoblat,oneoblon,oneobheight,oneobradid - use obsmod,only: radar_no_thinning + use obsmod,only: radar_no_thinning,reduce_diag use gsi_4dvar, only: l4dvar,time_4dvar use convinfo, only: nconvtype,ctwind,icuse,ioctype - use convthin, only: make3grids,map3grids,del3grids,use_all + use convthin, only: make3grids,map3grids_m,del3grids,use_all use read_l2bufr_mod, only: invtllv use qcmod, only: erradar_inflate use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model @@ -182,12 +182,10 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg real(r_kind), allocatable, dimension(:) :: zl_thin real(r_kind),dimension(nsig):: hges,zges real(r_kind) sin2,termg,termr,termrg,zobs,height - integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2 + integer(i_kind) iout,ntdrvr_thin2 real(r_kind) crit1,timedif real(r_kind),parameter:: r16000 = 16000.0_r_kind logical :: luse - integer(i_kind) maxout,maxdata - integer(i_kind),allocatable,dimension(:):: isort !--General declarations integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, & @@ -203,10 +201,14 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg clat0,slat0,dlat,dlon,thiserr,thislon,thislat, & rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter real(r_kind) :: azm,cosazm_earth,sinazm_earth,cosazm,sinazm - real(r_kind) :: radartwindow + real(r_kind) :: radartwindow,usage real(r_kind) :: rmins_an,rmins_ob real(r_kind),allocatable,dimension(:,:):: cdata_all real(r_double) rstation_id + logical, allocatable,dimension(:) :: rusage,rthin + logical save_all +! integer(i_kind) numthin,numqc,numrem,numall + integer(i_kind) nxdata,pmot character(8) cstaid character(4) this_staid @@ -266,22 +268,19 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg !--Allocate cdata_all array - allocate(cdata_all(maxdat,maxobs),isort(maxobs)) + allocate(cdata_all(maxdat,maxobs),rusage(maxobs),rthin(maxobs)) rmesh=rmesh_vr zmesh=zmesh_vr - maxout=0 - maxdata=0 - isort=0 ntdrvr_thin2=0 icntpnt=0 zflag=0 use_all=.true. - if (ithin > 0) then - write(6,*)'READ_RADAR: ithin,rmesh :',ithin,rmesh + if (ithin == 1) then + write(6,*)'READ_RADAR: rmesh :',rmesh use_all=.false. if(zflag == 0)then nlevz=nsig @@ -306,8 +305,8 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg iostat=ierror,form='formatted') - fileopen: if (ierror == 0) then - read(lunrad,'(2i8)') nelv,nvol !read number of elevations and number of volumes + fileopen: if (ierror == 0) then + read(lunrad,'(2i8)') nelv,nvol !read number of elevations and number of volumes !*************************IMPORTANT***************************! @@ -319,93 +318,97 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg !------Begin processing--------------------------! + rusage = .true. + rthin = .false. + use_all=.true. - !-Obtain analysis time in minutes since reference date - call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978 - rmins_an=mins_an !convert to real number - - volumes: do v=1,nvol - - read(lunrad,'(i8)') nelv - allocate(strct_in_vel(1,nelv)) - tilts: do k=1,nelv - - read(lunrad,'(a4)') strct_in_vel(1,k)%radid - read(lunrad,'(i8)') strct_in_vel(1,k)%vcpnum - read(lunrad,'(6i8)') strct_in_vel(1,k)%year & - ,strct_in_vel(1,k)%month & - ,strct_in_vel(1,k)%day & - ,strct_in_vel(1,k)%hour & - ,strct_in_vel(1,k)%minute & - ,strct_in_vel(1,k)%second - read(lunrad,'(2f10.3,f10.1)') strct_in_vel(1,k)%radlat & - ,strct_in_vel(1,k)%radlon & - ,strct_in_vel(1,k)%radhgt - read(lunrad,'(2f8.1)') strct_in_vel(1,k)%fstgatdis & - ,strct_in_vel(1,k)%gateWidth - read(lunrad,'(f8.3)') strct_in_vel(1,k)%elev_angle - read(lunrad,'(2i8)') strct_in_vel(1,k)%num_beam & - ,strct_in_vel(1,k)%num_gate - na=strct_in_vel(1,k)%num_beam - nb=strct_in_vel(1,k)%num_gate - - !******allocate arrays within radar data type**********! - allocate(strct_in_vel(1,k)%azim(na)) - allocate(strct_in_vel(1,k)%field(nb,na)) - !******************************************************! + !-Obtain analysis time in minutes since reference date + + call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978 + rmins_an=mins_an !convert to real number - read(lunrad,'(f8.3)') strct_in_vel(1,k)%nyq_vel - read(lunrad,'(15f6.1)') (strct_in_vel(1,k)%azim(j),j=1,na) - read(lunrad,'(20f6.1)') ((strct_in_vel(1,k)%field(i,j),i=1,nb),j=1,na) - - - obdate(1)=strct_in_vel(1,k)%year - obdate(2)=strct_in_vel(1,k)%month - obdate(3)=strct_in_vel(1,k)%day - obdate(4)=strct_in_vel(1,k)%hour - obdate(5)=strct_in_vel(1,k)%minute - call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978 - rmins_ob=mins_ob !convert to real number - rmins_ob=rmins_ob+(strct_in_vel(1,k)%second*r60inv) !convert seconds to minutes and add to ob time - - !-Comparison is done in units of minutes - - timeb = rmins_ob-rmins_an + volumes: do v=1,nvol + + read(lunrad,'(i8)') nelv + allocate(strct_in_vel(1,nelv)) + tilts: do k=1,nelv + + read(lunrad,'(a4)') strct_in_vel(1,k)%radid + read(lunrad,'(i8)') strct_in_vel(1,k)%vcpnum + read(lunrad,'(6i8)') strct_in_vel(1,k)%year & + ,strct_in_vel(1,k)%month & + ,strct_in_vel(1,k)%day & + ,strct_in_vel(1,k)%hour & + ,strct_in_vel(1,k)%minute & + ,strct_in_vel(1,k)%second + read(lunrad,'(2f10.3,f10.1)') strct_in_vel(1,k)%radlat & + ,strct_in_vel(1,k)%radlon & + ,strct_in_vel(1,k)%radhgt + read(lunrad,'(2f8.1)') strct_in_vel(1,k)%fstgatdis & + ,strct_in_vel(1,k)%gateWidth + read(lunrad,'(f8.3)') strct_in_vel(1,k)%elev_angle + read(lunrad,'(2i8)') strct_in_vel(1,k)%num_beam & + ,strct_in_vel(1,k)%num_gate + na=strct_in_vel(1,k)%num_beam + nb=strct_in_vel(1,k)%num_gate + + !******allocate arrays within radar data type**********! + allocate(strct_in_vel(1,k)%azim(na)) + allocate(strct_in_vel(1,k)%field(nb,na)) + !******************************************************! + + read(lunrad,'(f8.3)') strct_in_vel(1,k)%nyq_vel + read(lunrad,'(15f6.1)') (strct_in_vel(1,k)%azim(j),j=1,na) + read(lunrad,'(20f6.1)') ((strct_in_vel(1,k)%field(i,j),i=1,nb),j=1,na) + + + obdate(1)=strct_in_vel(1,k)%year + obdate(2)=strct_in_vel(1,k)%month + obdate(3)=strct_in_vel(1,k)%day + obdate(4)=strct_in_vel(1,k)%hour + obdate(5)=strct_in_vel(1,k)%minute + call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978 + rmins_ob=mins_ob !convert to real number + rmins_ob=rmins_ob+(strct_in_vel(1,k)%second*r60inv) !convert seconds to minutes and add to ob time + + !-Comparison is done in units of minutes + + timeb = rmins_ob-rmins_an - if(doradaroneob .and. (oneobradid /= strct_in_vel(1,k)%radid)) cycle tilts + if(doradaroneob .and. (oneobradid /= strct_in_vel(1,k)%radid)) cycle tilts - if(abs(timeb) > abs(radartwindow)) then - numbadtime=numbadtime+1 - cycle tilts !If not in time window, cycle the loop - end if - !--Time window check complete--! + if(abs(timeb) > abs(radartwindow)) then + numbadtime=numbadtime+1 + cycle tilts !If not in time window, cycle the loop + end if + !--Time window check complete--! - thistilt=strct_in_vel(1,k)%elev_angle - if (thistilt <= maxtilt .and. thistilt >= mintilt) then - - gates: do i=1,strct_in_vel(1,k)%num_gate,thin_freq - thisrange=strct_in_vel(1,k)%fstgatdis + real(i-1,r_kind)*strct_in_vel(1,k)%gateWidth + thistilt=strct_in_vel(1,k)%elev_angle + if (thistilt <= maxtilt .and. thistilt >= mintilt) then - !-Check to make sure observations are within specified range + gates: do i=1,strct_in_vel(1,k)%num_gate,thin_freq + thisrange=strct_in_vel(1,k)%fstgatdis + real(i-1,r_kind)*strct_in_vel(1,k)%gateWidth + + !-Check to make sure observations are within specified range - if (thisrange <= maxobrange .and. thisrange >= minobrange) then - - azms: do j=1,strct_in_vel(1,k)%num_beam - - !-Check to see if this is a missing observation) - nread=nread+1 - if ( strct_in_vel(1,k)%field(i,j) >= 999.0_r_kind ) then - num_missing=num_missing+1 - cycle azms !No reason to process the ob if it is missing - end if - - !--Find observation height using method from read_l2bufr_mod.f90 - - this_stahgt=strct_in_vel(1,k)%radhgt - aactual=rearth+this_stahgt - a43=four_thirds*aactual + if (thisrange <= maxobrange .and. thisrange >= minobrange) then + + azms: do j=1,strct_in_vel(1,k)%num_beam + + !-Check to see if this is a missing observation) + nread=nread+1 + if ( strct_in_vel(1,k)%field(i,j) >= 999.0_r_kind ) then + num_missing=num_missing+1 + cycle azms !No reason to process the ob if it is missing + end if + + !--Find observation height using method from read_l2bufr_mod.f90 + + this_stahgt=strct_in_vel(1,k)%radhgt + aactual=rearth+this_stahgt + a43=four_thirds*aactual thistiltr=thistilt*deg2rad selev0=sin(thistiltr) celev0=cos(thistiltr) @@ -443,179 +446,176 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg thislat=rlatglob*rad2deg thislon=rlonglob*rad2deg - if(doradaroneob) then - thislat=oneoblat - thislon=oneoblon - thishgt=oneobheight - endif + if(doradaroneob) then + thislat=oneoblat + thislon=oneoblon + thishgt=oneobheight + endif - if(thislon>=r360) thislon=thislon-r360 - if(thislon=r360) thislon=thislon-r360 + if(thislonzero) errmin=min(error,errmin) - if(abs(azm)>r400) then - ibadazm=ibadazm+1 - cycle azms - end if - - this_staid=strct_in_vel(1,k)%radid !Via equivalence in declaration, value is propagated - ! to rstation_id used below. + if(regional .and. .not. fv3_regional) then + cosazm_earth=cos(thisazimuthr) + sinazm_earth=sin(thisazimuthr) + call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,thislon,dlon,dlat) + azm=atan2(sinazm,cosazm) + else + azm=thisazimuthr + end if + + !--Do limited QC from read_radar.f90--! + error = erradar_inflate*thiserr + errmax=max(error,errmax) + if(thiserr>zero) errmin=min(error,errmin) + if(abs(azm)>r400) then + ibadazm=ibadazm+1 + cycle azms + end if + + this_staid=strct_in_vel(1,k)%radid !Via equivalence in declaration, value is propagated + ! to rstation_id used below. - ! Get model terrain at radar station location - ! If radar station is outside of grid, does not mean the - ! radar obs are outside the grid - therefore no need to - ! cycle azms. + ! Get model terrain at radar station location + ! If radar station is outside of grid, does not mean the + ! radar obs are outside the grid - therefore no need to + ! cycle azms. - radar_lon=deg2rad*strct_in_vel(1,k)%radlon - radar_lat=deg2rad*strct_in_vel(1,k)%radlat - call tll2xy(radar_lon,radar_lat,dlon_radar,dlat_radar,outside) - call deter_zsfc_model(dlat_radar,dlon_radar,zsges) + radar_lon=deg2rad*strct_in_vel(1,k)%radlon + radar_lat=deg2rad*strct_in_vel(1,k)%radlat + call tll2xy(radar_lon,radar_lat,dlon_radar,dlat_radar,outside) + call deter_zsfc_model(dlat_radar,dlon_radar,zsges) - ! Determines land surface type based on surrounding land - ! surface types + ! Determines land surface type based on surrounding land + ! surface types - t4dv=timeb*r60inv + t4dv=timeb*r60inv - call deter_sfc2(thislat,thislon,t4dv,idomsfc,skint,ff10,sfcr) - - + call deter_sfc2(thislat,thislon,t4dv,idomsfc,skint,ff10,sfcr) !#################### Data thinning ################### - icntpnt=icntpnt+1 - if(icntpnt>maxobs) exit - - if(ithin > 0)then - if(zflag == 0)then - klon1= int(dlon); klat1= int(dlat) - dx = dlon-klon1; dy = dlat-klat1 - dx1 = one-dx; dy1 = one-dy - w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + icntpnt=icntpnt+1 + if(icntpnt>maxobs) exit + pmot=pmot_vr + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. + + usage = zero + if(abs(icuse(ikx)) /= 1)usage=r100 - klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) - if (klon1==0) klon1=nlon - klatp1=min(nlat,klat1+1); klonp1=klon1+1 - if (klonp1==nlon+1) klonp1=1 - do kk=1,nsig - hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & - w10*hgtl_full(klatp1,klon1 ,kk) + & - w01*hgtl_full(klat1 ,klonp1,kk) + & - w11*hgtl_full(klatp1,klonp1,kk) - end do - sin2 = sin(thislat)*sin(thislat) - termg = grav_equator * & - ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) - termr = semi_major_axis /(one + flattening + grav_ratio - & - two*flattening*sin2) - termrg = (termg/grav)*termr - do kk=1,nsig - zges(kk) = (termr*hges(kk)) / (termrg-hges(kk)) - zl_thin(kk)=zges(kk) - end do - endif - - zobs = height - - ntmp=ndata ! counting moved to map3gridS - if (l4dvar) then - timedif = zero - else + if(ithin == 1)then + if(zflag == 0)then + klon1= int(dlon); klat1= int(dlat) + dx = dlon-klon1; dy = dlat-klat1 + dx1 = one-dx; dy1 = one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) + if (klon1==0) klon1=nlon + klatp1=min(nlat,klat1+1); klonp1=klon1+1 + if (klonp1==nlon+1) klonp1=1 + do kk=1,nsig + hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & + w10*hgtl_full(klatp1,klon1 ,kk) + & + w01*hgtl_full(klat1 ,klonp1,kk) + & + w11*hgtl_full(klatp1,klonp1,kk) + end do + sin2 = sin(thislat)*sin(thislat) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do kk=1,nsig + zges(kk) = (termr*hges(kk)) / (termrg-hges(kk)) + zl_thin(kk)=zges(kk) + end do + endif + + zobs = height + + if (l4dvar) then + timedif = zero + else ! timedif=abs(t4dv-toff) - timedif=abs(t4dv) !don't know about this - endif - crit1 = timedif/r6+half + timedif=abs(t4dv) !don't know about this + endif + crit1 = timedif/r6+half + + call map3grids_m(1,save_all,zflag,zl_thin,nlevz, & + thislat,thislon,zobs,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) + + if (.not. luse) then + ntdrvr_thin2=ntdrvr_thin2+1 + cycle + endif + + else + ndata =ndata+1 + endif + iout=ndata + + cdata_all(1,iout) = error ! wind obs error (m/s) + cdata_all(2,iout) = dlon ! grid relative longitude + cdata_all(3,iout) = dlat ! grid relative latitude + cdata_all(4,iout) = thishgt ! obs absolute height (m) + cdata_all(5,iout) = strct_in_vel(1,k)%field(i,j) ! wind obs (m/s) + cdata_all(6,iout) = azm ! azimuth angle (radians) + cdata_all(7,iout) = t4dv ! obs time (hour) - analysis relative + cdata_all(8,iout) = ikx ! type + cdata_all(9,iout) = thistiltr ! tilt angle (radians) + cdata_all(10,iout)= this_stahgt ! station elevation (m) + cdata_all(11,iout)= rstation_id ! station id + cdata_all(12,iout)= icuse(ikx) ! usage parameter + cdata_all(13,iout)= idomsfc ! dominate surface type + cdata_all(14,iout)= skint ! skin temperature + cdata_all(15,iout)= ff10 ! 10 meter wind factor + cdata_all(16,iout)= sfcr ! surface roughness + cdata_all(17,iout)=thislon*rad2deg ! earth relative longitude (degrees) + cdata_all(18,iout)=thislat*rad2deg ! earth relative latitude (degrees) + cdata_all(19,iout)=thisrange/1000._r_kind ! range from radar in km (used to estimate beam spread) + cdata_all(20,iout)=zsges ! model elevation at radar site + cdata_all(21,iout)=thiserr + cdata_all(22,iout)=two ! Level 2 data - call map3grids(1,zflag,zl_thin,nlevz,thislat,thislon,& - zobs,crit1,ndata,iout,icntpnt,iiout,luse, .false., .false.) - maxout=max(maxout,iout) - maxdata=max(maxdata,ndata) - - if (.not. luse) then - ntdrvr_thin2=ntdrvr_thin2+1 - cycle - endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(icntpnt)=iout - - else - ndata =ndata+1 - nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout - endif - - cdata_all(1,iout) = error ! wind obs error (m/s) - cdata_all(2,iout) = dlon ! grid relative longitude - cdata_all(3,iout) = dlat ! grid relative latitude - cdata_all(4,iout) = thishgt ! obs absolute height (m) - cdata_all(5,iout) = strct_in_vel(1,k)%field(i,j) ! wind obs (m/s) - cdata_all(6,iout) = azm ! azimuth angle (radians) - cdata_all(7,iout) = t4dv ! obs time (hour) - analysis relative - cdata_all(8,iout) = ikx ! type - cdata_all(9,iout) = thistiltr ! tilt angle (radians) - cdata_all(10,iout)= this_stahgt ! station elevation (m) - cdata_all(11,iout)= rstation_id ! station id - cdata_all(12,iout)= icuse(ikx) ! usage parameter - cdata_all(13,iout)= idomsfc ! dominate surface type - cdata_all(14,iout)= skint ! skin temperature - cdata_all(15,iout)= ff10 ! 10 meter wind factor - cdata_all(16,iout)= sfcr ! surface roughness - cdata_all(17,iout)=thislon*rad2deg ! earth relative longitude (degrees) - cdata_all(18,iout)=thislat*rad2deg ! earth relative latitude (degrees) - cdata_all(19,iout)=thisrange/1000._r_kind ! range from radar in km (used to estimate beam spread) - cdata_all(20,iout)=zsges ! model elevation at radar site - cdata_all(21,iout)=thiserr - cdata_all(22,iout)=two ! Level 2 data - - if(doradaroneob .and. (cdata_all(5,iout) > -99_r_kind) ) exit volumes - - end do azms !j - else - num_badrange=num_badrange+1 !If outside acceptable range, increment - end if !Range check - - end do gates !i + if(doradaroneob .and. (cdata_all(5,iout) > -99_r_kind) ) exit volumes + if(usage >= r100)rusage(iout)=.false. + + end do azms !j + else + num_badrange=num_badrange+1 !If outside acceptable range, increment + end if !Range check + + end do gates !i - else - num_badtilt=num_badtilt+1 !If outside acceptable tilts, increment - end if !Tilt check + else + num_badtilt=num_badtilt+1 !If outside acceptable tilts, increment + end if !Tilt check - end do tilts !k + end do tilts !k - do k=1,nelv - deallocate(strct_in_vel(1,k)%azim) - deallocate(strct_in_vel(1,k)%field) - enddo - deallocate(strct_in_vel) + do k=1,nelv + deallocate(strct_in_vel(1,k)%azim) + deallocate(strct_in_vel(1,k)%field) + enddo + deallocate(strct_in_vel) end do volumes !v close(lunrad) !modified to do one scan at a time @@ -626,6 +626,55 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg endif !end modified for thinning + + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' asciiradar ',trim(ioctype(ikx)),ikx,numall,& +! numrem,numqc,numthin +! If thinned data set quality mark to 14 + if (ithin == 1 ) then + do i=1,nxdata + if(rthin(i))cdata_all(12,i)=101._r_kind + end do + end if + +! If flag to not save thinned data is set - compress data + if(pmot /= 1)then + do i=1,nxdata + +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + if(i > ndata)then + do k=1,maxdat + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end if + end do + end if + end if + nodata=nodata+ndata + !---all looping done now print diagnostic output write(6,*)'READ_RADAR_WIND_ASCII: Reached eof on radar wind ascii file' @@ -645,12 +694,13 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg !---------------DEALLOCATE ARRAYS-------------! - deallocate(cdata_all) else !fileopen - write(6,*) 'READ_RADAR_WIND_ASCII: ERROR OPENING RADIAL VELOCITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...' + write(6,*) 'READ_RADAR_WIND_ASCII: ERROR OPENING RADIAL VELOCITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...' end if fileopen + deallocate(cdata_all,rusage,rthin) + end subroutine read_radar_wind_ascii diff --git a/src/gsi/read_rapidscat.f90 b/src/gsi/read_rapidscat.f90 index c952383df0..f1fffd43a8 100644 --- a/src/gsi/read_rapidscat.f90 +++ b/src/gsi/read_rapidscat.f90 @@ -43,16 +43,16 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,& tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,& rlats,rlons,fv3_regional - use qcmod, only: errormod,noiqc - use convthin, only: make3grids,map3grids,del3grids,use_all + use qcmod, only: errormod + use convthin, only: make3grids,map3grids_m,del3grids,use_all use constants, only: deg2rad,zero,rad2deg,one_tenth,& tiny_r_kind,huge_r_kind,r60inv,one_tenth,& one,two,three,four,five,half,quarter,r60inv,r10,r100,r2000 ! use converr,only: etabl - use obsmod, only: ran01dom,bmiss + use obsmod, only: ran01dom,bmiss,reduce_diag use convinfo, only: nconvtype, & icuse,ictype,icsubtype,ioctype, & - ithin_conv,rmesh_conv,pmesh_conv + ithin_conv,rmesh_conv,pmesh_conv,pmot_conv use gsi_4dvar, only: l4dvar,iwinbgn,winlen,time_4dvar,l4densvar,thin4d use deter_sfc_mod, only: deter_sfc_type,deter_sfc2 use mpimod, only: npe @@ -107,13 +107,12 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, integer(i_kind) ireadmg,ireadsb,iuse,mxtb,nmsgmax integer(i_kind) i,maxobs,idomsfc,nsattype - integer(i_kind) nc,nx,isflg,itx,nchanl + integer(i_kind) nc,nx,isflg,nchanl integer(i_kind) ntb,ntmatch,ncx,ncsave,ntread integer(i_kind) kk,klon1,klat1,klonp1,klatp1 integer(i_kind) nmind,lunin,idate,ilat,ilon,iret,k - integer(i_kind) nreal,ithin,iout,ntmp,icount,iiout,ii + integer(i_kind) nreal,ithin,iout,ii integer(i_kind) itype,iosub,ixsub,isubsub,iobsub - integer(i_kind) lim_qm integer(i_kind) nlevp ! vertical level for thinning integer(i_kind) pflag integer(i_kind) ntest,nvtest @@ -127,7 +126,7 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, integer(i_kind),dimension(nconvtype+1) :: ntx integer(i_kind),dimension(5):: idate5 - integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep + integer(i_kind),allocatable,dimension(:):: nrep integer(i_kind),allocatable,dimension(:,:)::tab integer(i_kind) ietabl,itypex,lcount,iflag,m @@ -135,14 +134,14 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, real(r_single),allocatable,dimension(:,:,:) :: etabl real(r_kind) toff,t4dv - real(r_kind) rmesh,ediff,usage,tdiff + real(r_kind) rmesh,ediff,tdiff real(r_kind) u0,v0,uob,vob,dx,dy,dx1,dy1,w00,w10,w01,w11 real(r_kind) dlnpob,ppb,ppb2,qifn,qify,ee real(r_kind) woe,dlat,dlon,dlat_earth,dlon_earth,oelev real(r_kind) dlat_earth_deg,dlon_earth_deg real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00 real(r_kind) vdisterrmax,u00,v00,uob1,vob1 - real(r_kind) del,werrmin,obserr,ppb1 + real(r_kind) del,werrmin,obserr,ppb1,usage real(r_kind) tsavg,ff10,sfcr,sstime,gstime,zz real(r_kind) crit1,timedif,xmesh,pmesh real(r_kind),dimension(nsig):: presl @@ -156,7 +155,11 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, real(r_double),dimension(1,1):: r_prvstg,r_sprvstg real(r_kind),allocatable,dimension(:):: presl_thin real(r_kind),allocatable,dimension(:,:):: cdata_all - real(r_kind),allocatable,dimension(:,:):: cdata_out + + logical,allocatable,dimension(:)::rthin,rusage + logical save_all +! integer(i_kind) numthin,numqc,numrem,numall + integer(i_kind) nxdata,pmot ! equivalence to handle character names equivalence(r_prvstg(1,1),c_prvstg) @@ -213,11 +216,6 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, werrmin=one nsattype=0 nreal=23 - if (noiqc) then - lim_qm=8 - else - lim_qm=4 - endif ! ** read convtype from convinfo file ! ** only read in rapidsat 296 for now ** @@ -252,7 +250,7 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, call getcount_bufr(infile,nmsgmax,mxtb) - allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax)) + allocate(lmsg(nmsgmax,ntread),tab(mxtb,2),nrep(nmsgmax)) lmsg = .false. maxobs=0 @@ -332,16 +330,13 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, end if tab(ntb,1)=ncsave tab(ntb,2)=nx - tab(ntb,3)=1 lmsg(nmsg,nx) = .true. end if enddo loop_report enddo msg_report ! Loop over convinfo file entries; operate on matches - allocate(cdata_all(nreal,maxobs),isort(maxobs)) - isort = 0 - cdata_all=zero + allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs)) nread=0 ntest=0 nvtest=0 @@ -352,6 +347,8 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, !! read satellite winds one type a time ! same as in the read_prepbufr.f90 file + rusage = .true. + rthin = .false. loop_convinfo: do nx=1,ntread use_all = .true. ithin=0 @@ -397,6 +394,17 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, ntb = 0 nmsg = 0 + if(nx == 1)then + pmot=0 + else + nc=ntx(nx) + pmot=nint(pmot_conv(nc)) + end if + if(pmot < 2 .and. reduce_diag)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. + use_all=.true. + loop_msg: do while(ireadmg(lunin,subset,idate) == 0) nmsg = nmsg+1 if(.not.lmsg(nmsg,nx)) then @@ -547,7 +555,7 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, obserr=(one-del)*etabl(itype,k1,4)+del*etabl(itype,k2,4) obserr=max(obserr,werrmin) ! Set usage variable - usage = 0 + usage = zero iuse=icuse(nc) if(iuse <= 0)usage=r100 @@ -584,7 +592,6 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, ! Special block for data thinning - if requested if (ithin > 0 .and. iuse >=0) then - ntmp=ndata ! counting moved to map3gridS ! Set data quality index for thinning if (thin4d) then @@ -601,22 +608,16 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, end do endif - call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - ppb,crit1,ndata,iout,ntb,iiout,luse,.false.,.false.) + call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, & + dlat_earth,dlon_earth,ppb,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) if (.not. luse) cycle loop_readsb - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+2 - endif - isort(ntb)=iout else ndata=ndata+1 - nodata=nodata+2 - iout=ndata - isort(ntb)=iout endif + iout=ndata woe=obserr oelev=r10 @@ -659,6 +660,7 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, cdata_all(21,iout)=zz ! terrain height at ob location cdata_all(22,iout)=r_prvstg(1,1) ! provider name cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name + if(usage >= r100)rusage(ndata)=.false. enddo loop_readsb @@ -675,35 +677,57 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind, call closbf(lunin) ! Write header record and data to output file for further processing - allocate(iloc(ndata)) - icount=0 - do i=1,maxobs - if(isort(i) > 0)then - icount=icount+1 - iloc(icount)=isort(i) - end if - end do - if(ndata /= icount)then - write(6,*) ' READ_RAPIDSCAT: mix up in read_satwnd ,ndata,icount ',ndata,icount - call stop2(49) - end if - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - itx=iloc(i) - do k=1,nreal - cdata_out(k,i)=cdata_all(k,itx) - end do - end do - deallocate(iloc,isort,cdata_all) deallocate(etabl) - + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' rapid ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin +! If thinned data set usage + do i=1,nxdata + if(rthin(i))then + cdata_all(14,i)=100._r_kind + cdata_all(12,i)=14 + end if + end do +! If flag to not save thinned data is set - compress data + do i=1,nxdata +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 1) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + do k=1,nreal + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end do + end if + nodata=nodata+ndata + deallocate(rusage,rthin) - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) cdata_out + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) + + deallocate(cdata_all) - deallocate(cdata_out) -900 continue if(diagnostic_reg .and. ntest>0) write(6,*)'READ_RAPIDSCAT: ',& 'ntest,disterrmax=',ntest,disterrmax if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_RAPIDSCAT: ',& diff --git a/src/gsi/read_satmar.f90 b/src/gsi/read_satmar.f90 index 673872e308..e9062a65f6 100644 --- a/src/gsi/read_satmar.f90 +++ b/src/gsi/read_satmar.f90 @@ -70,9 +70,11 @@ subroutine read_satmar (nread, ndata, nodata, & use gridmod, only: regional, rlats,rlons,nlat,nlon,txy2ll,tll2xy, & twodvar_regional use satthin, only: map2tgrid,destroygrids,makegrids - use convinfo, only: ithin_conv,rmesh_conv,nconvtype,icuse,ictype,ioctype,ctwind - use convthin, only: make3grids,use_all,map3grids,del3grids - use obsmod, only: bmiss,hilbert_curve + use convinfo, only: ithin_conv,rmesh_conv,nconvtype,icuse,ictype,ioctype,ctwind, & + pmot_conv +! use convinfo, only: icsubtype + use convthin, only: make3grids,use_all,map3grids_m,del3grids + use obsmod, only: bmiss,hilbert_curve,reduce_diag use mpimod, only: npe implicit none @@ -98,15 +100,14 @@ subroutine read_satmar (nread, ndata, nodata, & real (r_kind),parameter :: r6 = 6.0_r_kind real (r_kind),parameter :: dflt_err = 0.2_r_kind ! - integer(i_kind) :: tot,cnt,cnt1,k,ntmp,iout,iiout + integer(i_kind) :: tot,cnt,cnt1,k,iout,i integer(i_kind) :: ireadmg,ireadsb,idate integer(i_kind) :: iRec,ierr,nc,i1,ilat,ilon,nchanl,nlevp,indsat integer(i_kind) :: nmind, nrec integer(i_kind) :: thisobtype_usage, iuse ! real - real(r_kind),allocatable,dimension(:, :) :: data_all,data_out + real(r_kind),allocatable,dimension(:, :) :: data_all real(r_kind),allocatable,dimension(:):: DumForThin - integer(i_kind),allocatable,dimension(:):: isort,iloc ! real(r_kind),allocatable,dimension(: ) :: data_1d real(r_kind) :: dlon,dlat real(r_kind) :: tdiff,crit1,timedif,toff @@ -171,6 +172,11 @@ subroutine read_satmar (nread, ndata, nodata, & integer(i_kind),parameter :: howvRatMiuSigma = 3 integer(i_kind),parameter :: howvRathowvDpth = 2 real(r_kind),parameter :: howvDistm = 10000.0_r_kind + logical,allocatable,dimension(:)::rthin,rusage + logical save_all +! integer(i_kind) numthin,numqc,numrem,numall + integer(i_kind) nxdata,pmot + ! ! call init_constants_derived lhilbert = twodvar_regional .and. hilbert_curve @@ -203,9 +209,9 @@ subroutine read_satmar (nread, ndata, nodata, & end if ! ! *#* Thinning *#*! - use_all = .true. - ithin=ithin_conv(nc) - if (ithin > 0 ) then + use_all = .true. + ithin=ithin_conv(nc) + if (ithin > 0 ) then rmesh=rmesh_conv(nc) use_all = .false. nlevp=1 !Dummy for using make3grids @@ -214,7 +220,7 @@ subroutine read_satmar (nread, ndata, nodata, & call make3grids(xmesh,nlevp) write(6,'(A,1x,A,1x,A,I4,1x,f8.2,1x,I3,1x,I3)')myname,': ioctype(nc),ictype(nc),rmesh,nlevp,nc ',& trim(ioctype(nc)),ictype(nc),rmesh,nlevp,nc - endif + endif ! ! *#* Main - Start *#*! open(lun11,file=trim(infile),action='read',form='unformatted', iostat=ierr) @@ -236,13 +242,19 @@ subroutine read_satmar (nread, ndata, nodata, & close(lun11) ! ! Allocate Arrays for all the data - allocate (data_all (nreal, cnt),isort(cnt)) - isort = 0 + allocate (data_all (nreal, cnt),rusage(cnt),rthin(cnt)) ! ! Loop over file open(lun11,file=trim(infile),action='read',form='unformatted') call openbf(lun11,'IN',lun11) call datelen(dtLen) + pmot=nint(pmot_conv(nc)) + if(pmot < 2 .and. reduce_diag)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. + rusage = .true. + rthin = .false. + use_all=.true. ! read_msg: do while(ireadmg(lun11,subset,idate) == 0) do i1 = 1,nosat @@ -394,7 +406,6 @@ subroutine read_satmar (nread, ndata, nodata, & cnt = 0 iuse=icuse(nc) if (ithin > 0 .and. iuse >=0) then - ntmp=ndata if (thin4d) then timedif = zero ! crit1=0.01_r_kind else @@ -402,20 +413,15 @@ subroutine read_satmar (nread, ndata, nodata, & end if crit1 = timedif/r6+half ! - call map3grids(-1,0,DumForThin,nlevp,dlat_earth,dlon_earth & - ,one ,crit1,ndata,iout,nrec,iiout,luse,.false.,.false.) + call map3grids_m(-1,save_all,0,DumForThin,nlevp, & + dlat_earth,dlon_earth,one,crit1,ndata,& + luse,cnt,rthin,.false.,.false.) + if (.not. luse) cycle - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(nrec)=iout else ! - no thinnning ndata=ndata+1 - nodata=nodata+1 - iout=ndata - isort(nrec)=iout endif + iout=ndata ! usage = zero !- Set usage variable :: practically useless if (howv_1d(2)<=tiny_r_kind) howv_1d(2)=dflt_err @@ -462,44 +468,67 @@ subroutine read_satmar (nread, ndata, nodata, & enddo read_msg call closbf(lun11) ! Write header record and data to output file for further processing - allocate(iloc(ndata)) - cnt1 = 0 - do i1=1,size(data_all,2) - if(isort(i1) > 0)then - cnt1=cnt1 + 1 - iloc(cnt1)=isort(i1) - end if - end do - if(ndata /= cnt1)then - write(6,*) myname,': ndata and icount do not match STOPPING...ndata,cnt1,cnt ',ndata,cnt1,cnt - call stop2(50) - end if -! - allocate(data_out(nreal,ndata)) - do i1=1,ndata - iout=iloc(i1) - do k=1,nreal - data_out(k,i1)=data_all(k,iout) - end do - end do - deallocate(iloc,isort,data_all) - - call count_obs(ndata,nreal,ilat,ilon,data_out,nobs) - - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata - write(lunout) data_out - deallocate(data_out) - - if (ndata == 0) then - write(6,*)myname,': closbf(',lun11,') no data' - endif - close(lun11) ! + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' smar ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin +! If thinned data set usage + do i=1,nxdata + if(rthin(i))data_all(11,i)=100._r_kind + end do +! If flag to not save thinned data is set - compress data + if(pmot /= 1)then + do i=1,nxdata +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + if(i > ndata)then + do k=1,nreal + data_all(k,ndata)=data_all(k,i) + end do + end if + end if + end do + end if + nodata=nodata+ndata + end if + ! Deallocate local arrays if (ithin > 0 ) then deallocate(DumForThin) call del3grids end if + + call count_obs(ndata,nreal,ilat,ilon,data_all,nobs) + + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata + write(lunout) ((data_all(k,i1),k=1,nreal),i1=1,ndata) + deallocate(data_all,rusage,rthin) + + if (ndata == 0) then + write(6,*)myname,': closbf(',lun11,') no data' + endif + close(lun11) +! ! end subroutine read_satmar ! diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index 943cf4d47b..56283306fe 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -107,15 +107,15 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,& rlats,rlons,twodvar_regional,wrf_nmm_regional,fv3_regional use qcmod, only: errormod,njqc - use convthin, only: make3grids,map3grids,map3grids_m,del3grids,use_all - use convthin_time, only: make3grids_tm,map3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm + use convthin, only: make3grids,map3grids_m,del3grids,use_all + use convthin_time, only: make3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm use constants, only: deg2rad,zero,rad2deg,one_tenth,& tiny_r_kind,huge_r_kind,r60inv,one_tenth,& one,two,three,four,five,half,quarter,r60inv,r100,r2000 use converr,only: etabl use converr_uv,only: etabl_uv,isuble_uv,maxsub_uv use convb_uv,only: btabl_uv - use obsmod, only: perturb_obs,perturb_fact,ran01dom,bmiss + use obsmod, only: perturb_obs,perturb_fact,ran01dom,bmiss,reduce_diag use convinfo, only: nconvtype, & icuse,ictype,icsubtype,ioctype, & ithin_conv,rmesh_conv,pmesh_conv,pmot_conv,ptime_conv, & @@ -174,12 +174,12 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis integer(i_kind) mxtb,nmsgmax,qcret integer(i_kind) ireadmg,ireadsb,iuse integer(i_kind) i,maxobs,idomsfc,nsattype,ncount - integer(i_kind) nc,nx,isflg,itx,j,nchanl + integer(i_kind) nc,nx,isflg,j,nchanl integer(i_kind) ntb,ntmatch,ncx,ncsave,ntread integer(i_kind) kk,klon1,klat1,klonp1,klatp1 integer(i_kind) nmind,lunin,idate,ilat,ilon,iret,k - integer(i_kind) nreal,ithin,iout,ntmp,icount,iiout,ii - integer(i_kind) itype,iosub,ixsub,isubsub,iobsub,itypey,ierr + integer(i_kind) nreal,ithin,iout,ii + integer(i_kind) itype,iosub,ixsub,isubsub,iobsub,itypey,ierr,ihdr9 integer(i_kind) qm integer(i_kind) nlevp ! vertical level for thinning integer(i_kind) pflag @@ -191,36 +191,42 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis integer(i_kind),dimension(nconvtype+1) :: ntx integer(i_kind),dimension(5):: idate5 - integer(i_kind),allocatable,dimension(:):: nrep,isort,iloc + integer(i_kind),allocatable,dimension(:):: nrep,istab integer(i_kind),allocatable,dimension(:,:):: tab integer(i_kind) :: icnt(1000) - integer(i_kind) ntime,itime + integer(i_kind) ntime,itime,istype real(r_kind) toff,t4dv - real(r_kind) rmesh,ediff,usage,tdiff + real(r_kind) rmesh,ediff,tdiff real(r_kind) u0,v0,uob,vob,dx,dy,dx1,dy1,w00,w10,w01,w11 - real(r_kind) dlnpob,ppb,ppb2,qifn,qify,ee,ree,pct1,experr_norm + real(r_kind) dlnpob,ppb,qifn,qify,ee,ree,pct1,experr_norm real(r_kind) woe,dlat,dlon,dlat_earth,dlon_earth real(r_kind) dlat_earth_deg,dlon_earth_deg real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00 - real(r_kind) vdisterrmax,u00,v00,uob1,vob1 - real(r_kind) del,werrmin,obserr,ppb1,var_jb,wjbmin,wjbmax + real(r_kind) vdisterrmax,u00,v00 + real(r_kind) del,werrmin,obserr,var_jb,wjbmin,wjbmax +! real(r_kind) ppb1,ppb2,uob1,vob1 real(r_kind) tsavg,ff10,sfcr,sstime,gstime,zz - real(r_kind) crit1,timedif,xmesh,pmesh,pmot,ptime + real(r_kind) crit1,timedif,xmesh,pmesh,ptime real(r_kind),dimension(nsig):: presl real(r_double),dimension(13):: hdrdat real(r_double),dimension(4):: obsdat real(r_double),dimension(2) :: hdrdat_test,hdrdat_005099 - real(r_double),dimension(3,5) :: heightdat - real(r_double),dimension(6,4) :: derdwdat +! real(r_double),dimension(3,5) :: heightdat +! real(r_double),dimension(6,4) :: derdwdat real(r_double),dimension(3,12) :: qcdat real(r_double),dimension(1,1):: r_prvstg,r_sprvstg real(r_kind),allocatable,dimension(:):: presl_thin - real(r_kind),allocatable,dimension(:):: rusage - real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out + real(r_kind),allocatable,dimension(:,:):: cdata_all + + logical,allocatable,dimension(:)::rthin,rusage + logical save_all + !integer(i_kind) numthin,numqc,numrem,numall + integer(i_kind) nxdata,pmot + ! GOES-16 new BUFR related variables real(r_double) :: rep_array @@ -302,11 +308,12 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis call getcount_bufr(infile,nmsgmax,mxtb) - allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax)) + allocate(lmsg(nmsgmax,ntread),istab(nmsgmax),tab(mxtb,3),nrep(nmsgmax)) lmsg = .false. maxobs=0 tab=0 + istab=0 nmsg=0 nrep=0 ntb =0 @@ -317,6 +324,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis msg_report: do while (ireadmg(lunin,subset,idate) == 0) ! if(trim(subset) == 'NC005012') cycle msg_report + istype=0 ! Time offset if(nmsg == 0) call time_4dvar(idate,toff) nmsg=nmsg+1 @@ -324,15 +332,85 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis write(6,*)'READ_SATWND: messages exceed maximum ',nmsgmax call stop2(49) endif + if(trim(subset) == 'NC005064' .or. trim(subset) == 'NC005065' .or. & + trim(subset) == 'NC005066') then +! EUMETSAT satellite IDS + istype=1 + else if(trim(subset) == 'NC005067' .or. trim(subset) == 'NC005068' .or.& + trim(subset) == 'NC005069') then ! read new EUM BURF +! EUMETSAT new BUFR satellite IDS + istype=2 + else if(trim(subset) == 'NC005041' .or. trim(subset) == 'NC005042' .or. & + trim(subset) == 'NC005043') then +! JMA satellite IDS + istype=3 + else if(trim(subset) == 'NC005044' .or. trim(subset) == 'NC005045' .or. & + trim(subset) == 'NC005046') then +! JMA satellite IDS + istype=4 + + else if(trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or.& + trim(subset) == 'NC005049') then ! read new Him-8 BURF +! new HIM-8 BUFR + istype=5 + else if(trim(subset) == 'NC005001' .or. trim(subset) == 'NC005002' .or. & + trim(subset) == 'NC005003' ) then +! NESDIS BUFR + istype=6 + else if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. & + trim(subset) == 'NC005012' ) then +! NESDIS BUFR + istype=7 + else if(trim(subset) == 'NC005070' .or. trim(subset) == 'NC005071' ) then +! NASA AQUA and Terra winds + istype=8 + else if( trim(subset) == 'NC005080') then +! EUMETSAT and NOAA polar winds + istype=9 + else if( trim(subset) == 'NC005081') then +! EUMETSAT polar winds + istype=10 + else if( trim(subset) == 'NC005019') then +! GOES shortwave winds + istype=11 + else if( trim(subset) == 'NC005072') then +! LEOGEO (LeoGeo) winds + istype=12 + else if( trim(subset) == 'NC005090') then +! VIIRS winds + istype=13 + else if(trim(subset) == 'NC005091') then +! VIIRS N-20 with new sequence + istype=14 + else if(trim(subset) == 'NC005030') then +! GOES-R IR LW winds + istype=15 + else if(trim(subset) == 'NC005039') then +! GOES-R IR SW winds + istype=16 + else if(trim(subset) == 'NC005032') then +! GOES-R VIS winds + istype=17 + else if(trim(subset) == 'NC005034') then +! GOES-R WV cloud top + istype=18 + else if(trim(subset) == 'NC005031') then +! GOES-R WV clear sky/deep layer + istype=19 + else if(trim(subset) == 'NC005099') then + istype=20 + else +! write(6,*) ' subset not found ',trim(subset),nmsg + end if + istab(nmsg)=istype loop_report: do while (ireadsb(lunin) == 0) ntb = ntb+1 - maxobs=maxobs+1 nrep(nmsg)=nrep(nmsg)+1 + maxobs=maxobs+1 if (ntb>mxtb) then write(6,*)'READ_SATWND: reports exceed maximum ',mxtb call stop2(49) endif - call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v1) ! SWQM doesn't exist for GOES-R/new BUFR/ hence hdrdat(13)=MISSING. @@ -341,206 +419,195 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis iobsub=0 itype=-1 iobsub=int(hdrdat(1)) + ihdr9=nint(hdrdat(9)) - if(trim(subset) == 'NC005064' .or. trim(subset) == 'NC005065' .or. & - trim(subset) == 'NC005066') then + if(istype == 1) then if( hdrdat(1) = r50) then !the range of EUMETSAT satellite IDS - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds itype=253 - else if(hdrdat(9) == two) then ! visible winds + else if(ihdr9 == 2) then ! visible winds itype=243 - else if(hdrdat(9) == three) then ! WV cloud top + else if(ihdr9 == 3) then ! WV cloud top itype=254 - else if(hdrdat(9) >= four) then ! WV deep layer, monitored + else if(ihdr9 >= 4) then ! WV deep layer, monitored itype=254 endif endif - else if(trim(subset) == 'NC005067' .or. trim(subset) == 'NC005068' .or.& - trim(subset) == 'NC005069') then ! read new EUM BURF + else if(istype == 2) then ! read new EUM BURF if( hdrdat(1) = r50) then !the range of EUMETSAT satellite IDS - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds itype=253 - else if(hdrdat(9) == two) then ! visible winds + else if(ihdr9 == 2) then ! visible winds itype=243 - else if(hdrdat(9) == three) then ! WV cloud top + else if(ihdr9 == 3) then ! WV cloud top itype=254 - else if(hdrdat(9) >= four) then ! WV deep layer, monitored + else if(ihdr9 >= 4) then ! WV deep layer, monitored itype=254 endif endif - else if(trim(subset) == 'NC005041' .or. trim(subset) == 'NC005042' .or. & - trim(subset) == 'NC005043') then + else if(istype == 3) then if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds itype=252 - else if(hdrdat(9) == two) then ! visible winds + else if(ihdr9 == 2) then ! visible winds itype=242 - else if(hdrdat(9) == three) then ! WV cloud top + else if(ihdr9 == 3) then ! WV cloud top itype=250 - else if(hdrdat(9) >= four) then ! WV deep layer,monitored + else if(ihdr9 >= 4) then ! WV deep layer,monitored itype=250 endif endif - else if(trim(subset) == 'NC005044' .or. trim(subset) == 'NC005045' .or. & - trim(subset) == 'NC005046') then + else if(istype == 4) then if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds itype=252 - else if(hdrdat(9) == two) then ! visible winds + else if(ihdr9 == 2) then ! visible winds itype=242 - else if(hdrdat(9) == three) then ! WV cloud top + else if(ihdr9 == 3) then ! WV cloud top itype=250 - else if(hdrdat(9) >= four) then ! WV deep layer,monitored + else if(ihdr9 >= 4) then ! WV deep layer,monitored itype=250 endif endif - else if(trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or.& - trim(subset) == 'NC005049') then ! read new Him-8 BURF + else if(istype == 5) then ! read new Him-8 BURF if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds itype=252 - else if(hdrdat(9) == two) then ! visible winds + else if(ihdr9 == 2) then ! visible winds itype=242 - else if(hdrdat(9) == three) then ! WV cloud top + else if(ihdr9 == 3) then ! WV cloud top itype=250 - else if(hdrdat(9) >= four) then ! WV deep layer, monitored + else if(ihdr9 >= 4) then ! WV deep layer, monitored itype=250 endif endif - else if(trim(subset) == 'NC005001' .or. trim(subset) == 'NC005002' .or. & - trim(subset) == 'NC005003' ) then + else if(istype == 6) then if( hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDS - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds if(hdrdat(12) <50000000000000.0_r_kind) then itype=245 else - itype=240 ! short wave IR winds + itype=240 ! short wave IR winds endif - else if(hdrdat(9) == two ) then ! visible winds + else if(ihdr9 == 2 ) then ! visible winds itype=251 - else if(hdrdat(9) == three ) then ! WV cloud top + else if(ihdr9 == 3 ) then ! WV cloud top itype=246 - else if(hdrdat(9) >= four ) then ! WV deep layer,monitored + else if(ihdr9 >= 4 ) then ! WV deep layer,monitored itype=247 endif endif - else if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. & - trim(subset) == 'NC005012' ) then + else if(istype == 7) then if( hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDS - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds if(hdrdat(12) <50000000000000.0_r_kind) then itype=245 else - itype=240 ! short wave IR winds + itype=240 ! short wave IR winds endif - else if(hdrdat(9) == two ) then ! visible winds + else if(ihdr9 == 2 ) then ! visible winds itype=251 - else if(hdrdat(9) == three ) then ! WV cloud top + else if(ihdr9 == 3 ) then ! WV cloud top itype=246 - else if(hdrdat(9) >= four ) then ! WV deep layer,monitored + else if(ihdr9 >= 4 ) then ! WV deep layer,monitored itype=247 endif endif - else if(trim(subset) == 'NC005070' .or. trim(subset) == 'NC005071' ) then + else if(istype == 8) then if( hdrdat(1) >=r700 .and. hdrdat(1) <= r799 ) then ! the range of NASA Terra and Aqua satellite IDs - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds itype=257 - else if(hdrdat(9) == three) then ! WV cloud top + else if(ihdr9 == 3) then ! WV cloud top itype=258 - else if(hdrdat(9) >= four) then ! WV deep layer + else if(ihdr9 >= 4) then ! WV deep layer itype=259 endif endif - else if( trim(subset) == 'NC005080') then + else if(istype == 9) then if( hdrdat(1) <10.0_r_kind .or. (hdrdat(1) >= 200.0_r_kind .and. & hdrdat(1) <=223.0_r_kind) ) then ! the range of EUMETSAT and NOAA polar orbit satellite IDs - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds itype=244 else write(6,*) 'READ_SATWND: wrong derived method value' endif endif - else if( trim(subset) == 'NC005081') then + else if(istype == 10) then if( hdrdat(1) <10.0_r_kind ) then ! the range of EUMETSAT polar orbit satellite IDs new BUFR - if(hdrdat(9) == one) then ! IR winds + if(ihdr9 == 1) then ! IR winds itype=244 else write(6,*) 'READ_SATWND: wrong derived method value' endif endif - else if( trim(subset) == 'NC005019') then ! GOES shortwave winds + else if(istype == 11) then ! GOES shortwave winds if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! The range of NESDIS satellite IDS - if(hdrdat(9) == one) then ! short wave IR winds + if(ihdr9 == 1) then ! short wave IR winds itype=240 endif endif - else if( trim(subset) == 'NC005072') then ! LEOGEO (LeoGeo) winds + else if(istype == 12) then ! LEOGEO (LeoGeo) winds if(hdrdat(1) == 854 ) then ! LeoGeo satellite ID - if(hdrdat(9) == one) then ! LEOGEO IRwinds + if(ihdr9 == 1) then ! LEOGEO IRwinds itype=255 endif endif - else if( trim(subset) == 'NC005090') then ! VIIRS winds + else if(istype == 13) then ! VIIRS winds if(hdrdat(1) >=r200 .and. hdrdat(1) <=r250 ) then ! The range of satellite IDS - if(hdrdat(9) == one) then ! VIIRS IR winds + if(ihdr9 == 1) then ! VIIRS IR winds itype=260 endif endif - else if(trim(subset) == 'NC005091') then ! VIIRS N-20 with new sequence -! Commented out, because we need clarification for SWCM/hdrdat(9) from Yi Song + else if(istype == 14) then ! VIIRS N-20 with new sequence +! Commented out, because we need clarification for SWCM/ihdr9 from Yi Song ! NOTE: Once it is confirmed that SWCM values are sensible, apply this logic and ! replace lines 685-702 - ! if(hdrdat(9) == one) then ! VIIRS IR + ! if(ihdr9 == 1) then ! VIIRS IR ! winds ! itype=260 ! endif !Temporary solution replacing the commented code above - if(trim(subset) == 'NC005091') then ! IR LW winds - itype=260 - endif + itype=260 !GOES-R section of the 'if' statement over 'subsets' - else if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. & - trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039' .or. trim(subset) == 'NC005099') then -! Commented out, because we need clarification for SWCM/hdrdat(9) from Yi Song +! Commented out, because we need clarification for SWCM/ihdr9 from Yi Song ! NOTE: Once it is confirmed that SWCM values are sensible, apply this logic and replace lines 685-702 -! if(hdrdat(9) == one) then +! if(ihdr9 == 1) then ! if(hdrdat(12) <50000000000000.0_r_kind) then ! itype=245 ! GOES-R IR(LW) winds ! else ! itype=240 ! GOES-R IR(SW) winds ! endif -! else if(hdrdat(9) == two ) then +! else if(ihdr9 == 2 ) then ! itype=251 ! GOES-R VIS winds -! else if(hdrdat(9) == three ) then +! else if(ihdr9 == 3 ) then ! itype=246 ! GOES-R CT WV winds -! else if(hdrdat(9) >= four ) then +! else if(ihdr9 >= 4 ) then ! itype=247 ! GOES-R CS WV winds ! endif !Temporary solution replacing the commented code above - if(trim(subset) == 'NC005030') then ! IR LW winds - itype=245 - else if(trim(subset) == 'NC005039') then ! IR SW winds - itype=240 - else if(trim(subset) == 'NC005032') then ! VIS winds - itype=251 - else if(trim(subset) == 'NC005034') then ! WV cloud top - itype=246 - else if(trim(subset) == 'NC005031') then ! WV clear sky/deep layer - itype=247 - else if(trim(subset) == 'NC005099') then - itype=241 - endif + else if(istype == 15) then ! IR LW winds + itype=245 + else if(istype == 16) then ! IR SW winds + itype=240 + else if(istype == 17) then ! VIS winds + itype=251 + else if(istype == 18) then ! WV cloud top + itype=246 + else if(istype == 19) then ! WV clear sky/deep layer + itype=247 + else if(istype == 20) then + itype=241 else ! wind is not recognised and itype is not assigned cycle loop_report endif @@ -574,7 +641,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Save information for next read if(ncsave /= 0) then - maxobs=maxobs+1 nx=1 if(ithin_conv(ncsave) > 0 .and. ithin_conv(ncsave) <5)then do ii=2,ntread @@ -583,24 +649,21 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis end if tab(ntb,1)=ncsave tab(ntb,2)=nx - tab(ntb,3)=1 + tab(ntb,3)=itype lmsg(nmsg,nx) = .true. end if enddo loop_report enddo msg_report - - - allocate(cdata_all(nreal,maxobs),isort(maxobs),rusage(maxobs)) - isort = 0 - cdata_all=zero nread=0 ntest=0 nvtest=0 nchanl=0 ilon=2 ilat=3 - rusage=101.0_r_kind + allocate(cdata_all(nreal,maxobs),rthin(maxobs),rusage(maxobs)) + rusage = .true. + rthin = .false. loop_convinfo: do nx=1,ntread @@ -608,13 +671,16 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis use_all = .true. use_all_tm = .true. ithin=0 +! Default for non thinned data is save all + pmot=0 + if(nx >1) then nc=ntx(nx) ithin=ithin_conv(nc) + pmot = pmot_conv(nc) if (ithin > 0 .and. ithin <5) then rmesh=rmesh_conv(nc) pmesh=pmesh_conv(nc) - pmot=pmot_conv(nc) ptime=ptime_conv(nc) if(pmesh > zero) then pflag=1 @@ -640,12 +706,16 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis enddo endif endif - write(6,'(a52,a16,I5,f10.2,2i5,f10.2,i5,2f10.2)') & + write(6,'(a52,a16,I5,f10.2,2i5,f10.2,i5,i5,f10.2)') & ' READ_SATWND: ictype(nc),rmesh,pflag,nlevp,pmesh,nc ', & ioctype(nc),ictype(nc),rmesh,pflag,nlevp,pmesh,nc,pmot,ptime endif endif + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. + ! Open and read the file once for each satwnd type call closbf(lunin) open(lunin,file=trim(infile),form='unformatted') @@ -656,31 +726,34 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ncount=0 loop_msg: do while(IREADMG(lunin,subset,idate) == 0) nmsg = nmsg+1 - if(.not.lmsg(nmsg,nx)) then + istype = istab(nmsg) + if(.not.lmsg(nmsg,nx) .or. istype == 3 .or. istype == 6) then +! currently istypes 3 and 6 not used. If adding needs to be deleted from above line +! as well as below. ntb=ntb+nrep(nmsg) cycle loop_msg ! no useable reports this mesage, skip ahead report count end if loop_readsb: do while(ireadsb(lunin) == 0) ntb = ntb+1 - nc=tab(ntb,1) + nc = tab(ntb,1) if(nc <= 0 .or. tab(ntb,2) /= nx) cycle loop_readsb + itype = tab(ntb,3) + if(itype <= 0) cycle loop_readsb hdrdat=bmiss obsdat=bmiss - heightdat=bmiss - derdwdat=bmiss +! heightdat=bmiss +! derdwdat=bmiss qcdat=bmiss - iobsub=0 uob=bmiss vob=bmiss ppb=bmiss - ppb1=bmiss - ppb2=bmiss - uob1=bmiss - vob1=bmiss +! ppb1=bmiss +! ppb2=bmiss +! uob1=bmiss +! vob1=bmiss ee=r110 qifn=r110 qify=r110 - qm=2 ! test for BUFR version using lat/lon mnemonics call ufbint(lunin,hdrdat_test,2,1,iret, 'CLAT CLON') @@ -694,15 +767,16 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! reject data with missing pressure or wind ppb=obsdat(2) - if(ppb>rmiss .or. hdrdat(3)>rmiss .or. obsdat(4)>rmiss) cycle loop_readsb + if(ppb>rmiss .or. hdrdat(3)>rmiss .or. obsdat(4)>rmiss) cycle loop_readsb if(ppb>r10000) ppb=ppb/r100 ! ppb<10000 may indicate data reported in daPa or hPa ! reject date above 125mb (or 850 for regional) - if (ppb twind) cycle loop_readsb endif - iosub=0 ! reject data with bad lat/lon if(abs(hdrdat(2)) >r90 ) cycle loop_readsb @@ -728,6 +801,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis if( hdrdat(3) > r360) cycle loop_readsb qm=2 iobsub=int(hdrdat(1)) + ihdr9=nint(hdrdat(9)) write(stationid,'(i3)') iobsub ! counter for satwnd types @@ -744,247 +818,312 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis if(.not.do_qc) then continue - else if(trim(subset) == 'NC005064' .or. trim(subset) == 'NC005065' .or. & - trim(subset) == 'NC005066') then - if( hdrdat(1) = r50) then ! the range of EUMETSAT satellite IDs - c_prvstg='EUMETSAT' - if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree - if(hdrdat(9) == one) then ! IR winds - itype=253 - c_station_id='IR'//stationid - c_sprvstg='IR' - else if(hdrdat(9) == two) then ! visible winds - itype=243 - c_station_id='VI'//stationid - c_sprvstg='VI' - else if(hdrdat(9) == three) then ! WV cloud top, try to assimilate - itype=254 - c_station_id='WV'//stationid - c_sprvstg='WV' - else if(hdrdat(9) >= four) then ! WV deep layer,monitoring - itype=254 - qm=9 ! quality mark as 9, means the observation error needed to be set - c_station_id='WV'//stationid - c_sprvstg='WV' - endif + else if(istype == 1) then + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree + c_prvstg='EUMETSAT' + if(ihdr9 == 1) then ! IR winds +! itype=253 + c_station_id='IR'//stationid + c_sprvstg='IR' + else if(ihdr9 == 2) then ! visible winds +! itype=243 + c_station_id='VI'//stationid + c_sprvstg='VI' + else if(ihdr9 == 3) then ! WV cloud top, try to assimilate +! itype=254 + c_station_id='WV'//stationid + c_sprvstg='WV' + else if(ihdr9 >= 4) then ! WV deep layer,monitoring +! itype=254 + qm=9 ! quality mark as 9, means the observation error needed to be set + c_station_id='WV'//stationid + c_sprvstg='WV' + endif ! get quality information - call ufbrep(lunin,qcdat,3,12,iret,qcstr) - do j=4,9 - if( qify r105) then - qify=qcdat(3,j) - else if(qcdat(2,j) == two .and. qifn >r105) then - qifn=qcdat(3,j) - else if(qcdat(2,j) == three .and. ee >r105) then - ee=qcdat(3,j) - endif + do j=4,9 + if( qify r105) then + qify=qcdat(3,j) + else if(qcdat(2,j) == two .and. qifn >r105) then + qifn=qcdat(3,j) + else if(qcdat(2,j) == three .and. ee >r105) then + ee=qcdat(3,j) endif - enddo - if(qifn <85.0_r_kind ) then ! qifn, QI without forecast - qm=15 endif + enddo + if(qifn <85.0_r_kind ) then ! qifn, QI without forecast + qm=15 + endif +! Extra block for new EUMETSAT BUFR: Start + else if(istype == 2)then ! new EUM BUFR + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree + c_prvstg='EUMETSAT' + if(ihdr9 == 1) then ! IR winds +! itype=253 + c_station_id='IR'//stationid + c_sprvstg='IR' + else if(ihdr9 == 2) then ! visible winds +! itype=243 + c_station_id='VI'//stationid + c_sprvstg='VI' + else if(ihdr9 == 3) then ! WV cloud top, try to assimilate +! itype=254 + c_station_id='WV'//stationid + c_sprvstg='WV' + else if(ihdr9 >= 4) then ! WV deep layer,monitoring +! itype=254 + qm=9 ! quality mark as 9, means the observation error needed to be set + c_station_id='WV'//stationid + c_sprvstg='WV' + endif +! get quality information THIS SECTION NEEDS TO BE TESTED!!! + call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') + irep_array = max(1,int(rep_array)) + allocate( amvivr(2,irep_array)) + call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') + pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova + deallocate( amvivr ) + call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF + qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR + ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] + if(qifn <85.0_r_kind ) then ! qifn, QI without forecast + qm=15 + endif +! Extra block for new EUMETSAT BUFR: End + else if(istype == 4) then ! JMA + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree + c_prvstg='JMA' + if(ihdr9 == 1) then ! IR winds +! itype=252 + c_station_id='IR'//stationid + c_sprvstg='IR' + else if(ihdr9 == 2) then ! visible winds +! itype=242 + c_station_id='VI'//stationid + c_sprvstg='VI' + else if(ihdr9 == 3) then ! WV cloud top +! itype=250 + c_station_id='WV'//stationid + c_sprvstg='WV' + else if(ihdr9 >= 4) then ! WV deep layer,as monitoring +! itype=250 + qm=9 + c_station_id='WV'//stationid + c_sprvstg='WV' endif - else if(trim(subset) == 'NC005044' .or. trim(subset) == 'NC005045' .or. & ! JMA - trim(subset) == 'NC005046') then - if(hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS - c_prvstg='JMA' - if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree - if(hdrdat(9) == one) then ! IR winds - itype=252 - c_station_id='IR'//stationid - c_sprvstg='IR' - else if(hdrdat(9) == two) then ! visible winds - itype=242 - c_station_id='VI'//stationid - c_sprvstg='VI' - else if(hdrdat(9) == three) then ! WV cloud top - itype=250 - c_station_id='WV'//stationid - c_sprvstg='WV' - else if(hdrdat(9) >=four) then ! WV deep layer,as monitoring - itype=250 - qm=9 - c_station_id='WV'//stationid - c_sprvstg='WV' - endif ! get quality information - call ufbrep(lunin,qcdat,3,12,iret,qcstr) - do j=4,9 - if( qify <=r105 .and. qifn r105 ) then - qify=qcdat(3,j) - else if(qcdat(2,j) == 102.0_r_kind .and. qifn >r105 ) then - qifn=qcdat(3,j) - else if(qcdat(2,j) == 103.0_r_kind .and. ee >r105) then - ee=qcdat(3,j) - endif + do j=4,9 + if( qify <=r105 .and. qifn r105 ) then + qify=qcdat(3,j) + else if(qcdat(2,j) == 102.0_r_kind .and. qifn >r105 ) then + qifn=qcdat(3,j) + else if(qcdat(2,j) == 103.0_r_kind .and. ee >r105) then + ee=qcdat(3,j) endif - enddo - - if(qifn <85.0_r_kind ) then ! qifn: QI value without forecast - qm=15 endif + enddo + + if(qifn <85.0_r_kind ) then ! qifn: QI value without forecast + qm=15 endif - else if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. & ! NESDIS GOES - trim(subset) == 'NC005012' ) then - if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDS - c_prvstg='NESDIS' - if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree - if(hdrdat(9) == one) then ! IR winds - if(hdrdat(12) <50000000000000.0_r_kind) then ! for channel 4 - itype=245 - c_station_id='IR'//stationid - c_sprvstg='IR' - else - itype=240 ! short wave winds - c_station_id='IR'//stationid - c_sprvstg='IR' - endif - else if(hdrdat(9) == two ) then ! visible winds - itype=251 - c_station_id='VI'//stationid - c_sprvstg='VI' - else if(hdrdat(9) == three) then ! WV cloud top - itype=246 - c_station_id='WV'//stationid - c_sprvstg='WV' - else if(hdrdat(9) >= four) then ! WV deep layer.mornitored set in convinfo file - itype=247 - c_station_id='WV'//stationid - c_sprvstg='WV' +! Extra block for new JMA BUFR: Start + else if(istype == 5)then ! new JMA BUFR + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree + c_prvstg='JMA' + if(ihdr9 == 1) then ! IR winds +! itype=252 + c_station_id='IR'//stationid + c_sprvstg='IR' + else if(ihdr9 == 2) then ! visible winds +! itype=242 + c_station_id='VI'//stationid + c_sprvstg='VI' + else if(ihdr9 == 3) then ! WV cloud top +! itype=250 + c_station_id='WV'//stationid + c_sprvstg='WV' + else if(ihdr9 >= 4) then ! WV deep layer,monitoring +! itype=250 + qm=9 ! quality mark as 9, means the observation error needed to be set + c_station_id='WV'//stationid + c_sprvstg='WV' + endif +! get quality information THIS SECTION NEEDS TO BE TESTED!!! + call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') + irep_array = max(1,int(rep_array)) + allocate( amvivr(2,irep_array)) + call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') + pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova + deallocate( amvivr ) + call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF + qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR + ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] + if(qifn <85.0_r_kind ) then ! qifn, QI without forecast + qm=15 + endif +! Extra block for new JMA BUFR: End + else if(istype == 7)then ! NESDIS GOES + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree + c_prvstg='NESDIS' + if(ihdr9 == 1) then ! IR winds + if(hdrdat(12) <50000000000000.0_r_kind) then ! for channel 4 +! itype=245 + c_station_id='IR'//stationid + c_sprvstg='IR' + else +! itype=240 ! short wave winds + c_station_id='IR'//stationid + c_sprvstg='IR' endif - call ufbrep(lunin,qcdat,3,8,iret,qcstr) + else if(ihdr9 == 2) then ! visible winds +! itype=251 + c_station_id='VI'//stationid + c_sprvstg='VI' + else if(ihdr9 == 3) then ! WV cloud top +! itype=246 + c_station_id='WV'//stationid + c_sprvstg='WV' + else if(ihdr9 >= 4) then ! WV deep layer.mornitored set in convinfo file +! itype=247 + c_station_id='WV'//stationid + c_sprvstg='WV' + endif ! get quality information - do j=1,8 - if( qify <=r105 .and. qifn r105 ) then - qifn=qcdat(3,j) - else if(qcdat(2,j) == three .and. qify >r105) then - qify=qcdat(3,j) - else if( qcdat(2,j) == four .and. ee >r105) then - ee=qcdat(3,j) - endif + do j=1,8 + if( qify <=r105 .and. qifn r105 ) then + qifn=qcdat(3,j) + else if(qcdat(2,j) == three .and. qify >r105) then + qify=qcdat(3,j) + else if( qcdat(2,j) == four .and. ee >r105) then + ee=qcdat(3,j) endif - enddo -!QI not applied to CAWV for now - may in the future - if(qifn <85.0_r_kind .and. itype /= 247) then - qm=15 endif - if(wrf_nmm_regional) then + enddo +!QI not applied to CAWV for now - may in the future + if(qifn <85.0_r_kind .and. itype /= 247) then + qm=15 + endif + if(wrf_nmm_regional) then ! Minimum speed requirement for CAWV of 8m/s for HWRF. ! Tighten QC for 247 winds by removing winds below 450hPa - if(itype == 247 .and. obsdat(4) < 8.0_r_kind .and. ppb > 450.0_r_kind) then - qm=15 + if(itype == 247 .and. obsdat(4) < 8.0_r_kind .and. ppb > 450.0_r_kind) then + qm=15 ! Tighten QC for 240 winds by remove winds above 700hPa - elseif(itype == 240 .and. ppb < 700.0_r_kind) then - qm=15 + elseif(itype == 240 .and. ppb < 700.0_r_kind) then + qm=15 ! Tighten QC for 251 winds by remove winds above 750hPa - elseif(itype == 251 .and. ppb < 750.0_r_kind) then - qm=15 - endif - else + elseif(itype == 251 .and. ppb < 750.0_r_kind) then + qm=15 + endif + else ! Minimum speed requirement for CAWV of 10m/s - if(itype == 247 .and. obsdat(4) < 10.0_r_kind) then - qm=15 - endif + if(itype == 247 .and. obsdat(4) < 10.0_r_kind) then + qm=15 endif endif - else if(trim(subset) == 'NC005070' .or. trim(subset) == 'NC005071') then ! MODIS - if(hdrdat(1) >=r700 .and. hdrdat(1) <= r799 ) then - c_prvstg='MODIS' - if(hdrdat(9) == one) then ! IR winds - itype=257 - c_station_id='IR'//stationid - c_sprvstg='IR' - else if(hdrdat(9) == three) then ! WV cloud top - itype=258 - c_station_id='WV'//stationid - c_sprvstg='WVCLOP' - else if(hdrdat(9) >= four) then ! WV deep layer - itype=259 - c_station_id='WV'//stationid - c_sprvstg='WVDLAYER' - endif + else if(istype == 8) then ! MODIS + c_prvstg='MODIS' + if(ihdr9 == 1) then ! IR winds +! itype=257 + c_station_id='IR'//stationid + c_sprvstg='IR' + else if(ihdr9 == 3) then ! WV cloud top +! itype=258 + c_station_id='WV'//stationid + c_sprvstg='WVCLOP' + else if(ihdr9 >= 4) then ! WV deep layer +! itype=259 + c_station_id='WV'//stationid + c_sprvstg='WVDLAYER' + endif ! get quality information - call ufbrep(lunin,qcdat,3,8,iret,qcstr) - do j=1,8 - if( qify <=r105 .and. qifn r105) then - qifn=qcdat(3,j) - else if(qcdat(2,j) == three .and. qify >r105) then - qify=qcdat(3,j) - else if( qcdat(2,j) == four .and. ee >r105 ) then - ee=qcdat(3,j) - endif + do j=1,8 + if( qify <=r105 .and. qifn r105) then + qifn=qcdat(3,j) + else if(qcdat(2,j) == three .and. qify >r105) then + qify=qcdat(3,j) + else if( qcdat(2,j) == four .and. ee >r105 ) then + ee=qcdat(3,j) endif - enddo - endif - else if( trim(subset) == 'NC005080') then ! AVHRR - if(hdrdat(1) <10.0_r_kind .or. (hdrdat(1) >= 200.0_r_kind .and. & - hdrdat(1) <=223.0_r_kind) ) then - c_prvstg='AVHRR' - if(hdrdat(9) == one) then ! IR winds - itype=244 - else - write(6,*) 'READ_SATWND: wrong derived method value' endif + enddo + else if(istype == 9) then ! AVHRR + c_prvstg='AVHRR' +! itype=244 ! get quality information - call ufbrep(lunin,qcdat,3,8,iret,qcstr) - do j=1,6 - if( qify <=r105 .and. qifn r105) then - qifn=qcdat(3,j) - else if(qcdat(2,j) == three .and. qify >r105) then - qify=qcdat(3,j) - else if( qcdat(2,j) == four .and. ee >r105) then - ee=qcdat(3,j) - endif + do j=1,6 + if( qify <=r105 .and. qifn r105) then + qifn=qcdat(3,j) + else if(qcdat(2,j) == three .and. qify >r105) then + qify=qcdat(3,j) + else if( qcdat(2,j) == four .and. ee >r105) then + ee=qcdat(3,j) endif - enddo - endif - else if( trim(subset) == 'NC005019') then ! GOES shortwave winds - if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! The range of NESDIS satellite IDS - c_prvstg='NESDIS' - if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree - if(hdrdat(9) == one) then ! short wave IR winds - itype=240 - c_station_id='IR'//stationid - c_sprvstg='IR' endif + enddo +! Extra block for new Metop/AVHRR BUFR: Start + else if(istype == 10) then ! Metop-B/C from EUMETSAT + c_prvstg='METOP' + if(ihdr9 == 1) then ! IRwinds +! itype=244 + c_station_id='IR'//stationid + c_sprvstg='IR' + else + write(6,*) 'READ_SATWND: wrong derived method value' + endif + call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') + irep_array = int(rep_array) + allocate( amvivr(2,irep_array)) + call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') + pct1 = amvivr(2,1) ! use of pct1 is limited to GOES-16/17) as introduced by Nebuda/Genkova + deallocate( amvivr ) + call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF + qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR + ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] +! Extra block for new Metop/AVHRR BUFR: End + else if(istype == 11) then ! GOES shortwave winds + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree + c_prvstg='NESDIS' + if(ihdr9 == 1) then ! short wave IR winds +! itype=240 + c_station_id='IR'//stationid + c_sprvstg='IR' + endif ! get quality information - call ufbrep(lunin,qcdat,3,8,iret,qcstr) - do j=1,6 - if( qify <=r105 .and. qifn r105) then - qifn=qcdat(3,j) - else if(qcdat(2,j) == three .and. qify >r105) then - qify=qcdat(3,j) - else if( qcdat(2,j) == four .and. ee >r105) then - ee=qcdat(3,j) - endif + do j=1,6 + if( qify <=r105 .and. qifn r105) then + qifn=qcdat(3,j) + else if(qcdat(2,j) == three .and. qify >r105) then + qify=qcdat(3,j) + else if( qcdat(2,j) == four .and. ee >r105) then + ee=qcdat(3,j) endif - enddo -! Tighten QC for 240 winds by removing winds above 700hPa - if(wrf_nmm_regional) then - if(itype == 240 .and. ppb < 700.0_r_kind) qm=15 endif + enddo +! Tighten QC for 240 winds by removing winds above 700hPa + if(wrf_nmm_regional) then + if(itype == 240 .and. ppb < 700.0_r_kind) qm=15 endif - else if( trim(subset) == 'NC005072') then ! LEOGEO (LeoGeo) winds + else if(istype == 12) then ! LEOGEO (LeoGeo) winds if(hdrdat(1) ==854 ) then ! LEOGEO satellite ID c_prvstg='LEOGEO' - if(hdrdat(9) == one) then !LEOGEO IR winds - itype=255 + if(ihdr9 == 1) then !LEOGEO IR winds +! itype=255 c_station_id='IR'//stationid c_sprvstg='IR' endif ! get quality information - call ufbrep(lunin,qcdat,3,8,iret,qcstr) !!! Rethink this strategy!!! qifn=qcdat(3,1) qify=qcdat(3,2) @@ -1002,327 +1141,208 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis !endif !enddo endif - else if( trim(subset) == 'NC005090') then ! VIIRS IR winds - if(hdrdat(1) >=r200 .and. hdrdat(1) <=r250 ) then ! The range of satellite IDS - c_prvstg='VIIRS' - if(hdrdat(9) == one) then ! VIIRS IR winds - itype=260 - c_station_id='IR'//stationid - c_sprvstg='IR' - endif + else if(istype == 13) then ! VIIRS IR winds + c_prvstg='VIIRS' + if(ihdr9 == 1) then ! VIIRS IR winds +! itype=260 + c_station_id='IR'//stationid + c_sprvstg='IR' + endif ! get quality information - call ufbrep(lunin,qcdat,3,8,iret,qcstr) - do j=1,6 - if( qify <=r105 .and. qifn r105) then - qifn=qcdat(3,j) - else if(qcdat(2,j) == three .and. qify >r105) then - qify=qcdat(3,j) - else if( qcdat(2,j) == four .and. ee >r105) then - ee=qcdat(3,j) - endif + do j=1,6 + if( qify <=r105 .and. qifn r105) then + qifn=qcdat(3,j) + else if(qcdat(2,j) == three .and. qify >r105) then + qify=qcdat(3,j) + else if( qcdat(2,j) == four .and. ee >r105) then + ee=qcdat(3,j) endif - enddo - endif + endif + enddo if(qifn <85.0_r_kind ) then ! qifn, QI without forecast qm=15 endif -! Extra block for new JMA BUFR: Start - else if(trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or. & - trim(subset) == 'NC005049') then ! read new JMA BURF - if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! The range of satellite IDs - c_prvstg='JMA' - if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree - if(hdrdat(9) == one) then ! IR winds - itype=252 - c_station_id='IR'//stationid - c_sprvstg='IR' - else if(hdrdat(9) == two) then ! visible winds - itype=242 - c_station_id='VI'//stationid - c_sprvstg='VI' - else if(hdrdat(9) == three) then ! WV cloud top - itype=250 - c_station_id='WV'//stationid - c_sprvstg='WV' - else if(hdrdat(9) >= four) then ! WV deep layer,monitoring - itype=250 - qm=9 ! quality mark as 9, means the observation error needed to be set - c_station_id='WV'//stationid - c_sprvstg='WV' - endif -! get quality information THIS SECTION NEEDS TO BE TESTED!!! - call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') - irep_array = max(1,int(rep_array)) - allocate( amvivr(2,irep_array)) - call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') - pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova - deallocate( amvivr ) - call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF - qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR - ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] - if(qifn <85.0_r_kind ) then ! qifn, QI without forecast - qm=15 - endif - endif -! Extra block for new JMA BUFR: End -! Extra block for new EUMETSAT BUFR: Start - else if(trim(subset) == 'NC005067' .or. trim(subset) == 'NC005068' .or. & - trim(subset) == 'NC005069') then ! read new EUM BURF - if( hdrdat(1) = r50 ) then ! The range of satellite IDs - c_prvstg='EUMETSAT' - if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree - if(hdrdat(9) == one) then ! IR winds - itype=253 - c_station_id='IR'//stationid - c_sprvstg='IR' - else if(hdrdat(9) == two) then ! visible winds - itype=243 - c_station_id='VI'//stationid - c_sprvstg='VI' - else if(hdrdat(9) == three) then ! WV cloud top, try to assimilate - itype=254 - c_station_id='WV'//stationid - c_sprvstg='WV' - else if(hdrdat(9) >= four) then ! WV deep layer,monitoring - itype=254 - qm=9 ! quality mark as 9, means the observation error needed to be set - c_station_id='WV'//stationid - c_sprvstg='WV' - endif -! get quality information THIS SECTION NEEDS TO BE TESTED!!! - call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') - irep_array = max(1,int(rep_array)) - allocate( amvivr(2,irep_array)) - call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') - pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova - deallocate( amvivr ) - call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF - qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR - ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] - if(qifn <85.0_r_kind ) then ! qifn, QI without forecast - qm=15 - endif - endif -! Extra block for new EUMETSAT BUFR: End -! Extra block for new Metop/AVHRR BUFR: Start - else if(trim(subset) == 'NC005081') then ! Metop-B/C from NESDIS - if( hdrdat(1) <10.0_r_kind ) then ! The range of satellite IDs - c_prvstg='METOP' - if(hdrdat(9) == one) then ! IRwinds - itype=244 - c_station_id='IR'//stationid - c_sprvstg='IR' - else - write(6,*) 'READ_SATWND: wrong derived method value' - endif - call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') - irep_array = int(rep_array) - allocate( amvivr(2,irep_array)) - call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') - pct1 = amvivr(2,1) ! use of pct1 is limited to GOES-16/17) as introduced by Nebuda/Genkova - deallocate( amvivr ) - call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF - qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR - ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] - endif -! Extra block for new Metop/AVHRR BUFR: End ! Extra block for VIIRS NOAA-20: Start - else if(trim(subset) == 'NC005091') then - if( hdrdat(1) >=r200 .and. hdrdat(1) <=r250 ) then ! Use this range in v16.* - c_prvstg='VIIRS' - if(trim(subset) == 'NC005091') then ! IR LW winds - itype=260 - c_station_id='IR'//stationid - c_sprvstg='IR' - !write(6,*)'itype= ',itype - endif - -! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}') -! irep_array = int(rep_array) -! allocate( amvaha(4,irep_array)) -! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST -! HOCT') -! deallocate( amvaha ) + else if(istype == 14) then + c_prvstg='VIIRS' ! IR LW winds +! itype=260 + c_station_id='IR'//stationid + c_sprvstg='IR' + !write(6,*)'itype= ',itype + +! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}') +! irep_array = int(rep_array) +! allocate( amvaha(4,irep_array)) +! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST +! HOCT') +! deallocate( amvaha ) ! -! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}') -! irep_array = int(rep_array) -! allocate( amviii(12,irep_array)) -! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID -! SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST') -! deallocate( amviii ) - - call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') - irep_array = int(rep_array) - allocate( amvivr(2,irep_array)) - call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') - pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova - deallocate( amvivr ) - -! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}') -! irep_array = int(rep_array) -! allocate( amvcld(12,irep_array)) -! ! MUCE --> MUNCEX within the new GOES16/17 and NOAA-20 VIIRS -! sequence (I.Genkova, J.Whiting) -! ! THIS CHANGE HAS NOT BEEN TESTED !!! -! !call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE -! VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT') -! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUNCEX -! VSAT TMDBST VSAT CDTP MUNCEX OECS CDTP HOCT COPT') -! deallocate( amvcld ) - - call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF - qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR - ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] - endif +! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}') +! irep_array = int(rep_array) +! allocate( amviii(12,irep_array)) +! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID +! SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST') +! deallocate( amviii ) + + call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') + irep_array = int(rep_array) + allocate( amvivr(2,irep_array)) + call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') + pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova + deallocate( amvivr ) + +! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}') +! irep_array = int(rep_array) +! allocate( amvcld(12,irep_array)) +! ! MUCE --> MUNCEX within the new GOES16/17 and NOAA-20 VIIRS +! sequence (I.Genkova, J.Whiting) +! ! THIS CHANGE HAS NOT BEEN TESTED !!! +! !call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE +! VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT') +! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUNCEX +! VSAT TMDBST VSAT CDTP MUNCEX OECS CDTP HOCT COPT') +! deallocate( amvcld ) + + call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF + qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR + ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] ! Extra block for VIIRS NOAA20: End ! Extra block for GOES-R winds: Start - else if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. & !IR(LW) / CS WV / VIS GOES-R like winds - trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039' .or. trim(subset) == 'NC005099') then !CT WV / IR(SW) GOES-R like winds + else if (istype >= 15 .and. istype <=20)then - if ( trim(subset) == 'NC005099' ) then - hdrdat(10)=61.23 ! set zenith angle for CIMSS AMVs to 67 to pass QC, no value in origional data - end if - if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDs - ! The sample newBUFR has SAID=259 (GOES-15) - ! When GOES-R SAID is assigned, pls check - ! if this range is still valid (Genkova)) - c_prvstg='NESDIS' + c_prvstg='GOESR' + if(istype == 15) then ! IR LW winds if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree - if(trim(subset) == 'NC005030') then ! IR LW winds - itype=245 - c_station_id='IR'//stationid - c_sprvstg='IR' - !write(6,*)'itype= ',itype - else if(trim(subset) == 'NC005039') then ! IR SW winds - itype=240 - c_station_id='IR'//stationid - c_sprvstg='IR' - !write(6,*)'itype= ',itype - else if(trim(subset) == 'NC005032') then ! VIS winds - itype=251 - c_station_id='VI'//stationid - c_sprvstg='VI' - !write(6,*)'itype= ',itype - else if(trim(subset) == 'NC005034') then ! WV cloud top - itype=246 - c_station_id='WV'//stationid - c_sprvstg='WV' - !write(6,*)'itype= ',itype - else if(trim(subset) == 'NC005031') then ! WV clear sky/deep layer - itype=247 - c_station_id='WV'//stationid - c_sprvstg='WV' +! itype=245 + c_station_id='IR'//stationid + c_sprvstg='IR' + !write(6,*)'itype= ',itype + else if(istype == 16) then ! IR SW winds + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree +! itype=240 + c_station_id='IR'//stationid + c_sprvstg='IRSW' + !write(6,*)'itype= ',itype + else if(istype == 17) then ! VIS winds + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree +! itype=251 + c_station_id='VI'//stationid + c_sprvstg='VIS' !write(6,*)'itype= ',itype - else if(trim(subset) == 'NC005099') then ! WV clear sky/deep layer - itype=241 - c_station_id='IR'//stationid - c_sprvstg='IR' - endif + else if(istype == 18) then ! WV cloud top + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree +! itype=246 + c_station_id='WV'//stationid + c_sprvstg='WVCT' + !write(6,*)'itype= ',itype + else if(istype == 19) then ! WV clear sky/deep layer + if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree +! itype=247 + c_station_id='WV'//stationid + c_sprvstg='WVCS' + !write(6,*)'itype= ',itype + else if(istype == 20) then ! WV clear sky/deep layer + hdrdat(10)=61.23 ! set zenith angle for CIMSS AMVs to 67 to pass QC, no value in origional data +! itype=241 + c_station_id='IR'//stationid + c_sprvstg='IR' + endif -! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}') -! irep_array = int(rep_array) -! allocate( amvaha(4,irep_array)) -! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST HOCT') -! deallocate( amvaha ) -! -! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}') -! irep_array = int(rep_array) -! allocate( amviii(12,irep_array)) -! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST') -! deallocate( amviii ) - - if (itype /= 241) then - - call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') - irep_array = int(rep_array) - allocate( amvivr(2,irep_array)) - call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') - pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova - deallocate( amvivr ) - -! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}') -! irep_array = int(rep_array) -! allocate( amvcld(12,irep_array)) -! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT') -! deallocate( amvcld ) - - call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') - qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR - ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] +! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}') +! irep_array = int(rep_array) +! allocate( amvaha(4,irep_array)) +! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST HOCT') +! deallocate( amvaha ) + +! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}') +! irep_array = int(rep_array) +! allocate( amviii(12,irep_array)) +! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST') +! deallocate( amviii ) + + if (itype /= 241) then + + call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') + irep_array = int(rep_array) + allocate( amvivr(2,irep_array)) + call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD') + pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova + deallocate( amvivr ) + +! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}') +! irep_array = int(rep_array) +! allocate( amvcld(12,irep_array)) +! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT') +! deallocate( amvcld ) + + call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') + qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR + ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] ! Additional QC introduced by Sharon Nebuda (for GOES-R winds from MSG proxy images) - if (qifn < 80_r_kind .or. qifn > r100 ) qm=15 !reject data with low QI - if (ppb < 125.0_r_kind) qm=15 !reject data above 125hPa: Trop check in setup.f90 - experr_norm = 10.0_r_kind - 0.1_r_kind * ee ! introduced by Santek/Nebuda - if (obsdat(4) > 0.1_r_kind) then ! obsdat(4) is the AMV speed - experr_norm = experr_norm/obsdat(4) - else - experr_norm = 100.0_r_kind - end if - if (experr_norm > 0.9_r_kind) qm=15 ! reject data with EE/SPD>0.9 - - if(wrf_nmm_regional) then - ! type 251 has been determine not suitable to be subjected to pct1 range check - if(itype==240 .or. itype==245 .or. itype==246 .or. itype==241) then - if (pct1 < 0.04_r_kind) qm=15 - if (pct1 > 0.50_r_kind) qm=15 - elseif (itype==251) then - if (pct1 > 0.50_r_kind) qm=15 - endif - 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.50_r_kind) qm=15 - endif - endif + if (qifn < 80_r_kind .or. qifn > r100 )then + qm=15 !reject data with low QI + else if (ppb < 125.0_r_kind) then + qm=15 !reject data above 125hPa: Trop check in setup.f90 + else if (obsdat(4) > 0.1_r_kind) then ! obsdat(4) is the AMV speed + experr_norm = (10.0_r_kind - 0.1_r_kind * ee)/obsdat(4) ! introduced by Santek/Nebuda + if (experr_norm > 0.9_r_kind) qm=15 ! reject data with EE/SPD>0.9 + else + qm=15 + end if + + if(wrf_nmm_regional) then + ! type 251 has been determine not suitable to be subjected to pct1 range check + if(itype==240 .or. itype==245 .or. itype==246 .or. itype==241) then + if (pct1 < 0.04_r_kind .or. pct1 > 0.50_r_kind) qm=15 + elseif (itype==251) then + if (pct1 > 0.50_r_kind) qm=15 + endif + 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 .or. pct1 > 0.50_r_kind) qm=15 + endif + endif ! GOES-16 additional QC addopting ECMWF's approach(Katie Lean,14IWW)-start - if (EC_AMV_QC) then - if (qifn < 90_r_kind .or. qifn > r100 ) qm=15 ! stricter QI - if (ppb < 150.0_r_kind) qm=15 ! all high level - if (itype==251 .and. ppb < 700.0_r_kind) qm=15 ! VIS - if (itype==246 .and. ppb > 300.0_r_kind) qm=15 ! WVCA - dlon_earth=hdrdat(3)*deg2rad - dlat_earth=hdrdat(2)*deg2rad - call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg) - if (isflg == 1 .and. ppb > 850.0_r_kind) qm=15 ! low over land - endif - - else ! Assign values for the mnemonics/variables missing in original datafile for type 241 + if (EC_AMV_QC) then + if (qifn < 90_r_kind .or. qifn > r100 ) qm=15 ! stricter QI + if (ppb < 150.0_r_kind) qm=15 ! all high level + if (itype==251 .and. ppb < 700.0_r_kind) qm=15 ! VIS + if (itype==246 .and. ppb > 300.0_r_kind) qm=15 ! WVCA + if (qm < 15)then + dlon_earth=hdrdat(3)*deg2rad + dlat_earth=hdrdat(2)*deg2rad + call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg) + if (isflg == 1 .and. ppb > 850.0_r_kind) qm=15 ! low over land + end if + endif + + else ! Assign values for the mnemonics/variables missing in original datafile for type 241 + + call ufbint(lunin,hdrdat_005099,2,1,iret, 'GNAPS PCCF'); + qifn=hdrdat_005099(2); + qm=2 ! do not reject the wind + pct1=0.4_r_kind ! do not reject the wind + ee=1.0_r_kind ! do not reject the wind - call ufbint(lunin,hdrdat_005099,2,1,iret, 'GNAPS PCCF'); - qifn=hdrdat_005099(2); - qm=2.0 ! do not reject the wind - pct1=0.4 ! do not reject the wind - ee=1.0 ! do not reject the wind - - endif + endif ! winds rejected by qc dont get used - if (qm == 15) usage=r100 - if (qm == 3 .or. qm ==7) woe=woe*r1_2 + if (qm == 3 .or. qm ==7) woe=woe*r1_2 ! set strings for diagnostic output - if(itype==240 ) then; c_prvstg='GOESR' ; c_sprvstg='IRSW' ; endif - if(itype==245 ) then; c_prvstg='GOESR' ; c_sprvstg='IR' ; endif - if(itype==246 ) then; c_prvstg='GOESR' ; c_sprvstg='WVCT' ; endif - if(itype==247 ) then; c_prvstg='GOESR' ; c_sprvstg='WVCS' ; endif - if(itype==251 ) then; c_prvstg='GOESR' ; c_sprvstg='VIS' ; endif - if(itype==241 ) then; c_prvstg='GOESR' ; c_sprvstg='IR' ; endif !to be revisited I.Genkova - endif ! Extra block for GOES-R winds: End else ! wind is not recognised and itype is not assigned - write(6,*) 'read_satwnd: WIND IS NOT RECOGNIZEd and we are in hell' + write(6,*) 'read_satwnd: WIND IS NOT RECOGNIZED ',istype,itype cycle loop_readsb endif ! assign types and get quality info : end - if ( itype == -1 ) cycle loop_readsb ! unassigned itype - if ( qify == zero) qify=r110 if ( qifn == zero) qifn=r110 if ( ee == zero) ee=r110 @@ -1353,8 +1373,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis call grdcrd1(dlon,rlons,nlon,1) endif - - !! detect surface type for IR winds monitoring over land for lat greter than 20N ! isflg - surface flag ! 0 sea @@ -1465,7 +1483,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis endif ! end of njqc if((itype==245 .or. itype==246) & - .and. (trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. trim(subset) == 'NC005012' )) then !only applies to AMVs from legacy algorithm (pre GOES-R) + .and. istype == 7) then !only applies to AMVs from legacy algorithm (pre GOES-R) ! using Santek quality control method,calculate the original ee value: ! NOTE: Up until GOES-R winds algorithm, EE (expected error, ee) is reported as percent 0-100% (the higher the ee, the better the wind quality) ! NOTE: In the new GOES-R BUFR, EE (expected error, ee) is reported in m/s (the smaller the ee, the better the wind quality) @@ -1489,16 +1507,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Reduce OE for the GOES-R winds by half following Sharon Nebuda's work ! GOES-R wind are identified/recognised here by subset, but it could be done by itype or SAID ! After completing the evaluation of GOES-R winds, REVISE this section!!! - if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. & - trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039' .or. trim(subset) == 'NC005099') then + if(istype >= 15 .and. istype <=20)then obserr=obserr/two endif -! Set usage variable - usage = 0 - iuse=icuse(nc) - if(iuse <= 0)usage=r100 - if(qm == 15 .or. qm == 12 .or. qm == 9)usage=r100 ! if(itype==240) then; c_prvstg='NESDIS' ; c_sprvstg='IR' ; endif ! if(itype==242) then; c_prvstg='JMA' ; c_sprvstg='VI' ; endif ! if(itype==243) then; c_prvstg='EUMETSAT' ; c_sprvstg='VI' ; endif @@ -1523,9 +1535,9 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis !! process the thining procedure ithin=ithin_conv(nc) - ithinp = ithin > 0 .and. ithin <5 .and. pflag /= 0 + ithinp = ithin > 0 .and. ithin <5 .and. qm < 4 ! if(ithinp .and. iuse >=0 )then - if(ithinp )then + if(ithinp .and. pflag /= 0 )then ! Interpolate guess pressure profile to observation location klon1= int(dlon); klat1= int(dlat) dx = dlon-klon1; dy = dlat-klat1 @@ -1544,31 +1556,23 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Compute depth of guess pressure layersat observation location end if + dlnpob=log(one_tenth*ppb) ! ln(pressure in cb) ppb=one_tenth*ppb ! from mb to cb ! Special block for data thinning - if requested - if (ithin > 0 .and. ithin <5 .and. iuse >=0 .and. qm <4) then - ntmp=ndata ! counting moved to map3gridS + if (ithinp) then ! Set data quality index for thinning if (thin4d) then timedif = zero else timedif=abs(t4dv-toff) endif + crit1 = timedif/r6+half if(itype == 243 .or. itype == 253 .or. itype == 254) then - if(qifn zero ) then itime=int((tdiff+three)/ptime)+1 if (itime >ntime) itime=ntime - if(pmot 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+2 - endif - rusage(iout)=usage - isort(ntb)=iout - else -! call map3grids_m_tm(-1,pflag,presl_thin,nlevp,ntime,dlat_earth,dlon_earth,& - call map3grids_m_tm(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - ppb,itime,crit1,ndata,iout,ntb,iiout,luse,maxobs,usage,rusage,.false.,.false.) - if (ndata > ntmp) then - nodata=nodata+2 - endif - isort(ntb)=iout - endif - else - if(pmot 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+2 - endif - isort(ntb)=iout - rusage(iout)=usage - else - call map3grids_m(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - ppb,crit1,ndata,iout,ntb,iiout,luse,maxobs,usage,rusage,.false.,.false.) - if (ndata > ntmp) then - nodata=nodata+2 - endif - isort(ntb)=iout - endif + call map3grids_m_tm(-1,save_all,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& + ppb,itime,crit1,ndata,luse,maxobs,rthin,.false.,.false.) + else + call map3grids_m(-1,save_all,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& + ppb,crit1,ndata,luse,maxobs,rthin,.false.,.false.) endif + if(.not. luse) cycle loop_readsb else ndata=ndata+1 - nodata=nodata+2 - iout=ndata - isort(ntb)=iout - rusage(iout)=usage endif + iout=ndata + iuse=icuse(nc) + if(iuse < 0)qm = 9 + if(qm > 7 .or. iuse < 0 )rusage(iout)=.false. inflate_error=.false. if (qm==3 .or. qm==7) inflate_error=.true. woe=obserr @@ -1653,7 +1624,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cdata_all(11,iout)=qifn +1000.0_r_kind*qify ! quality indicator cdata_all(12,iout)=qm ! quality mark cdata_all(13,iout)=obserr ! original obs error - cdata_all(14,iout)=usage ! usage parameter + cdata_all(14,iout)=0 ! usage parameter cdata_all(15,iout)=idomsfc ! dominate surface type cdata_all(16,iout)=tsavg ! skin temperature cdata_all(17,iout)=ff10 ! 10 meter wind factor @@ -1684,51 +1655,72 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis deallocate(presl_thin) call del3grids_tm endif - ! Normal exit - enddo loop_convinfo! loops over convinfo entry matches deallocate(lmsg,tab,nrep) ! Close unit to bufr file call closbf(lunin) - - ! Write header record and data to output file for further processing - allocate(iloc(ndata)) - icount=0 - do i=1,maxobs - if(isort(i) > 0)then - icount=icount+1 - iloc(icount)=isort(i) - end if - end do - if(ndata /= icount)then - write(6,*) ' READ_SATWND: mix up in read_satwnd ,ndata,icount ',ndata,icount - call stop2(49) - end if - - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - itx=iloc(i) - do k=1,13 - cdata_out(k,i)=cdata_all(k,itx) +! + if(ndata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,ndata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' smar ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin +! If thinned data set usage + do i=1,ndata + if(rthin(i))then + cdata_all(12,i)=14 + cdata_all(14,i)=101.0_r_kind + end if + if(.not. rusage(i))cdata_all(14,i) = 100.0_r_kind end do - cdata_out(14,i)=rusage(itx) - do k=15,nreal - cdata_out(k,i)=cdata_all(k,itx) + nxdata=ndata +! If flag to not save thinned data is set - compress data + ndata=0 + do i=1,nxdata +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 1) .or. & + (pmot == 2 .and. rusage(i) .and. .not. rthin(i)) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + do k=1,nreal + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if end do - end do - deallocate(iloc,isort,cdata_all,rusage) + nodata=nodata+2*ndata + end if + deallocate(rusage,rthin) + + + ! Write header record and data to output file for further processing - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) cdata_out + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) + + deallocate(cdata_all) - deallocate(cdata_out) -900 continue - if(diagnostic_reg .and. ntest>0) write(6,*)'READ_SATWND: ',& + if(diagnostic_reg)then + if(ntest>0) write(6,*)'READ_SATWND: ',& 'ntest,disterrmax=',ntest,disterrmax - if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_SATWND: ',& + if(nvtest>0) write(6,*)'READ_SATWND: ',& 'nvtest,vdisterrmax=',ntest,vdisterrmax + end if if (ndata == 0) then write(6,*)'READ_SATWND: closbf(',lunin,')' diff --git a/src/gsi/read_sfcwnd.f90 b/src/gsi/read_sfcwnd.f90 index 05c96b21fc..07fed808c7 100644 --- a/src/gsi/read_sfcwnd.f90 +++ b/src/gsi/read_sfcwnd.f90 @@ -48,19 +48,19 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,& tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,& rlats,rlons,fv3_regional - use qcmod, only: errormod,noiqc,njqc + use qcmod, only: errormod,njqc - use convthin, only: make3grids,map3grids,del3grids,use_all + use convthin, only: make3grids,map3grids_m,del3grids,use_all use constants, only: deg2rad,zero,rad2deg,one_tenth,& tiny_r_kind,huge_r_kind,r60inv,one_tenth,& one,two,three,four,five,half,quarter,r60inv,r10,r100,r2000 use converr,only: etabl use converr_uv,only: etabl_uv,isuble_uv,maxsub_uv use convb_uv,only: btabl_uv - use obsmod, only: ran01dom,bmiss + use obsmod, only: ran01dom,bmiss,reduce_diag use convinfo, only: nconvtype, & icuse,ictype,icsubtype,ioctype, & - ithin_conv,rmesh_conv,pmesh_conv + ithin_conv,rmesh_conv,pmesh_conv,pmot_conv use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d use deter_sfc_mod, only: deter_sfc_type,deter_sfc2 use mpimod, only: npe @@ -97,13 +97,12 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis integer(i_kind) ireadmg,ireadsb,iuse,mxtb,nmsgmax integer(i_kind) i,maxobs,idomsfc,nsattype,j,ncount - integer(i_kind) nc,nx,isflg,itx,nchanl + integer(i_kind) nc,nx,isflg,nchanl integer(i_kind) ntb,ntmatch,ncx,ncsave,ntread integer(i_kind) kk,klon1,klat1,klonp1,klatp1 integer(i_kind) nmind,lunin,idate,ilat,ilon,iret,k - integer(i_kind) nreal,ithin,iout,ntmp,icount,iiout,ii + integer(i_kind) nreal,ithin,iout,ii integer(i_kind) itype,iosub,ixsub,isubsub,iobsub - integer(i_kind) lim_qm integer(i_kind) nlevp ! vertical level for thinning integer(i_kind) pflag integer(i_kind) ntest,nvtest @@ -117,7 +116,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis integer(i_kind),dimension(nconvtype+1) :: ntx integer(i_kind),dimension(5):: idate5 - integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep + integer(i_kind),allocatable,dimension(:):: nrep integer(i_kind),allocatable,dimension(:,:)::tab ! integer(i_kind) itypex,lcount,iflag,m @@ -143,7 +142,13 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis real(r_double),dimension(5,4):: wnddat real(r_double),dimension(1,1):: r_prvstg,r_sprvstg real(r_kind),allocatable,dimension(:):: presl_thin - real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out + real(r_kind),allocatable,dimension(:,:):: cdata_all + + logical,allocatable,dimension(:)::rthin,rusage + logical save_all +! integer(i_kind) numthin,numqc,numrem,numall + integer(i_kind) nxdata,pmot + ! equivalence to handle character names equivalence(r_prvstg(1,1),c_prvstg) @@ -200,11 +205,6 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis werrmin=one nsattype=0 nreal=24 - if (noiqc) then - lim_qm=8 - else - lim_qm=4 - endif ! ** read convtype from convinfo file ! ** only read in OSCAT 291 for now ** @@ -239,7 +239,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis call getcount_bufr(infile,nmsgmax,mxtb) - allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax)) + allocate(lmsg(nmsgmax,ntread),tab(mxtb,2),nrep(nmsgmax)) lmsg = .false. maxobs=0 @@ -321,7 +321,6 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis end if tab(ntb,1)=ncsave tab(ntb,2)=nx - tab(ntb,3)=1 lmsg(nmsg,nx) = .true. end if enddo loop_report @@ -329,9 +328,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Loop over convinfo file entries; operate on matches - allocate(cdata_all(nreal,maxobs),isort(maxobs)) - isort = 0 - cdata_all=zero + allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs)) nread=0 ntest=0 nvtest=0 @@ -342,15 +339,19 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis !! read satellite winds one type a time ! same as in the read_prepbufr.f90 file + rusage = .true. + rthin = .false. loop_convinfo: do nx=1,ntread use_all = .true. ithin=0 + pmot=0 if(nx >1) then nc=ntx(nx) ithin=ithin_conv(nc) if (ithin > 0 ) then rmesh=rmesh_conv(nc) pmesh=pmesh_conv(nc) + pmot = pmot_conv(nc) use_all = .false. if(pmesh > zero) then pflag=1 @@ -376,6 +377,9 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ioctype(nc),ictype(nc),rmesh,pflag,nlevp,pmesh,nc endif endif + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. call closbf(lunin) close(lunin) @@ -473,9 +477,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis if(obsdat(3) >=1) cycle loop_readsb if(trim(subset) == 'NC012255') then ! OSCAT KNMI wind - if( hdrdat(1) == r421) then - itype=291 - endif + if( hdrdat(1) == r421) itype=291 endif @@ -642,7 +644,6 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Special block for data thinning - if requested if (ithin > 0 .and. iuse >=0) then - ntmp=ndata ! counting moved to map3gridS ! Set data quality index for thinning if (thin4d) then @@ -659,22 +660,16 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis end do endif - call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - ppb,crit1,ndata,iout,ntb,iiout,luse,.false.,.false.) + call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, & + dlat_earth,dlon_earth,ppb,crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) if (.not. luse) cycle loop_readsb - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+2 - endif - isort(ntb)=iout else ndata=ndata+1 - nodata=nodata+2 - iout=ndata - isort(ntb)=iout endif + iout=ndata woe=obserr oelev=r10 @@ -718,6 +713,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cdata_all(22,iout)=r_prvstg(1,1) ! provider name cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name cdata_all(24,iout)=var_jb ! non linear qc parameter + if(usage >= r100)rusage(ndata)=.false. enddo loop_readsb @@ -729,43 +725,69 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis deallocate(presl_thin) call del3grids endif + ! Normal exit enddo loop_convinfo! loops over convinfo entry matches call closbf(lunin) deallocate(lmsg,nrep,tab) - - ! Write header record and data to output file for further processing - allocate(iloc(ndata)) - icount=0 - do i=1,maxobs - if(isort(i) > 0)then - icount=icount+1 - iloc(icount)=isort(i) - end if - end do - if(ndata /= icount)then - write(6,*) ' READ_SFCWND: mix up in read_satwnd ,ndata,icount ',ndata,icount - call stop2(49) + nxdata=ndata + ndata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' sfc ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin +! If thinned data set usage + do i=1,nxdata + if(rthin(i))then + cdata_all(14,i)=101._r_kind + cdata_all(12,i)=14 + end if + end do +! If flag to not save thinned data is set - compress data + do i=1,nxdata +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 1) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + if(i > ndata)then + do k=1,nreal + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end if + end do + nodata=nodata+ndata end if + ! Write header record and data to output file for further processing + deallocate(rusage,rthin) - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - itx=iloc(i) - do k=1,nreal - cdata_out(k,i)=cdata_all(k,itx) - end do - end do - deallocate(iloc,isort,cdata_all) ! deallocate(etabl) + close(lunin) - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) cdata_out + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) - deallocate(cdata_out) -900 continue + deallocate(cdata_all) + if(diagnostic_reg .and. ntest>0) write(6,*)'READ_SFCWND: ',& 'ntest,disterrmax=',ntest,disterrmax if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_SFCWND: ',& @@ -777,7 +799,6 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis write(6,*) 'READ_SFCWND,nread,ndata,nreal,nodata=',nread,ndata,nreal,nodata - close(lunin) ! End of routine return diff --git a/src/gsi/read_viirs.f90 b/src/gsi/read_viirs.f90 index 66923c9896..ab80642f29 100644 --- a/src/gsi/read_viirs.f90 +++ b/src/gsi/read_viirs.f90 @@ -198,6 +198,7 @@ subroutine read_sst_viirs(mype,val_viirs,ithin,rmesh,jsatid,& bufsat = 226 else write(*,*) 'READ_SST_VIIRS: Unrecognized value for jsatid '//jsatid//':RETURNING' + deallocate(amesh,hsst_thd) return end if @@ -516,7 +517,7 @@ subroutine read_sst_viirs(mype,val_viirs,ithin,rmesh,jsatid,& endif ! Deallocate local arrays - deallocate(data_all) + deallocate(data_all,amesh,hsst_thd) if(diagnostic_reg.and.ntest>0 .and. mype_sub==mype_root) & write(6,*)'READ_VIIRS-M: ',& diff --git a/src/gsi/read_wcpbufr.f90 b/src/gsi/read_wcpbufr.f90 index f3daa5de43..65e70f4be8 100644 --- a/src/gsi/read_wcpbufr.f90 +++ b/src/gsi/read_wcpbufr.f90 @@ -47,11 +47,11 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& tll2xy,txy2ll, rlats,rlons use convinfo, only: nconvtype,ctwind, & ncmiter,ncgroup,ncnumgrp,icuse,ictype,icsubtype,ioctype, & - ithin_conv,rmesh_conv,pmesh_conv + ithin_conv,rmesh_conv,pmesh_conv,pmot_conv use converr,only: etabl - use obsmod, only: iadate, offtime_data, oberrflg + use obsmod, only: iadate, offtime_data, oberrflg,reduce_diag use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen,thin4d - use convthin, only: make3grids,map3grids,del3grids,use_all + use convthin, only: make3grids,map3grids_m,del3grids,use_all use mpimod, only: npe implicit none @@ -85,15 +85,15 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& character(8) c_station_id character(1) sidchr(8) - integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2,icount,iiout + integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2 integer(i_kind) lunin,i,maxobs,nmsgmax,mxtb integer(i_kind) kk,klon1,klat1,klonp1,klatp1 - integer(i_kind) nc,nx,ntread,itx,ii,ncsave + integer(i_kind) nc,nx,ntread,ii,ncsave integer(i_kind) ihh,idd,idate,iret,im,iy,k,levs integer(i_kind) kx,nreal,nchanl,ilat,ilon,ithin integer(i_kind) qm, swcpq, lwcpq integer(i_kind) nlevp ! vertical level for thinning - integer(i_kind) ntmp,iout + integer(i_kind) iout integer(i_kind) pflag,irec integer(i_kind) ntest,nvtest,iosub,ixsub,isubsub,iobsub integer(i_kind) kl,k1,k2 @@ -105,7 +105,7 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& integer(i_kind),dimension(255):: pqm integer(i_kind),dimension(nconvtype)::ntxall integer(i_kind),dimension(nconvtype+1)::ntx - integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep + integer(i_kind),allocatable,dimension(:):: nrep integer(i_kind),allocatable,dimension(:,:):: tab real(r_kind) time,timex,timeobs,toff,t4dv,zeps real(r_kind) rmesh,ediff,usage @@ -125,7 +125,12 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& real(r_kind),dimension(nsig-1):: dpres real(r_kind),dimension(255)::plevs real(r_kind),allocatable,dimension(:):: presl_thin - real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out + real(r_kind),allocatable,dimension(:,:):: cdata_all + logical,allocatable,dimension(:)::rthin,rusage + logical save_all +! integer(i_kind) numthin,numqc,numrem + integer(i_kind) nxdata,pmot,numall + real(r_double) rstation_id,qcmark_huge real(r_double),dimension(8):: hdr @@ -294,25 +299,28 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! loop over convinfo file entries; operate on matches - allocate(cdata_all(nreal,maxobs),isort(maxobs)) - isort = 0 - cdata_all=zero + allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs)) nread=0 ntest=0 nvtest=0 nchanl=0 ilon=2 ilat=3 + rusage = .true. + rthin = .false. loop_convinfo: do nx=1, ntread use_all = .true. ithin=0 + pmot=0 + if(nx > 1) then nc=ntx(nx) ithin=ithin_conv(nc) if (ithin > 0 ) then rmesh=rmesh_conv(nc) pmesh=pmesh_conv(nc) + pmot=nint(pmot_conv(nc)) use_all = .false. if(pmesh > zero) then pflag=1 @@ -338,6 +346,9 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh endif endif + if(reduce_diag .and. pmot < 2)pmot=pmot+2 + save_all=.false. + if(pmot /= 2 .and. pmot /= 0) save_all=.true. call closbf(lunin) @@ -380,32 +391,32 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& call ufbint(lunin,hdr,8,1,iret,hdstr) kx=hdr(5) - if(abs(hdr(3))>r90 .or. abs(hdr(2))>r360) cycle loop_readsb - if(hdr(2)== r360)hdr(2)=hdr(2)-r360 - if(hdr(2) < zero)hdr(2)=hdr(2)+r360 - dlon_earth_deg=hdr(2) - dlat_earth_deg=hdr(3) - dlon_earth=hdr(2)*deg2rad - dlat_earth=hdr(3)*deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate - if(diagnostic_reg) then - call txy2ll(dlon,dlat,rlon00,rlat00) - ntest=ntest+1 - cdist=sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* & - (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00)) - cdist=max(-one,min(cdist,one)) - disterr=acos(cdist)*rad2deg - disterrmax=max(disterrmax,disterr) - end if - if(outside) cycle loop_readsb ! check to see if outside regional domain - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif + if(abs(hdr(3))>r90 .or. abs(hdr(2))>r360) cycle loop_readsb + if(hdr(2)== r360)hdr(2)=hdr(2)-r360 + if(hdr(2) < zero)hdr(2)=hdr(2)+r360 + dlon_earth_deg=hdr(2) + dlat_earth_deg=hdr(3) + dlon_earth=hdr(2)*deg2rad + dlat_earth=hdr(3)*deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate + if(diagnostic_reg) then + call txy2ll(dlon,dlat,rlon00,rlat00) + ntest=ntest+1 + cdist=sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* & + (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00)) + cdist=max(-one,min(cdist,one)) + disterr=acos(cdist)*rad2deg + disterrmax=max(disterrmax,disterr) + end if + if(outside) cycle loop_readsb ! check to see if outside regional domain + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif !------------------------------------------------------------------------ @@ -436,22 +447,22 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& time_correction=zero end if - timeobs=real(real(hdr(4),r_single),r_double) - t4dv=timeobs + toff - zeps=1.0e-8_r_kind - if (t4dv -zeps) t4dv=zero - if (t4dv>winlen.and.t4dv -zeps) t4dv=zero + if (t4dv>winlen.and.t4dvwinlen) cycle loop_readsb ! outside time window - else - if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)))cycle loop_readsb ! outside time window - endif + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle loop_readsb ! outside time window + else + if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)))cycle loop_readsb ! outside time window + endif - timex=time + timex=time ! Extract data information on levels call ufbint(lunin,obsdat,5,255,levs,obstr) @@ -550,9 +561,11 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(qm > 15 .or. qm < 0) cycle loop_k_levs +! Set usage variable + usage = zero + ! Special block for data thinning - if requested if (ithin > 0) then - ntmp=ndata ! counting moved to map3gridS ! Set data quality index for thinning if (thin4d) then @@ -568,9 +581,12 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end do endif - call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - plevs(k),crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) + call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, & + dlat_earth,dlon_earth,plevs(k),crit1,ndata,& + luse,maxobs,rthin,.false.,.false.) + + if(rthin(ndata))usage=101._r_kind if (.not. luse) then if(k==levs) then cycle loop_readsb @@ -578,26 +594,17 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& cycle LOOP_K_LEVS endif endif - if(iiout > 0) isort(iiout)=0 - if(ndata > ntmp)then - nodata=nodata+1 - end if - isort(icntpnt)=iout else ndata=ndata+1 - nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout endif + iout=ndata if(ndata > maxobs) then write(6,*)'READ_WCPBUFR: ***WARNING*** ndata > maxobs for ',obstype ndata = maxobs end if -! Set usage variable - usage = zero if(icuse(nc) <= 0)usage=100._r_kind @@ -610,6 +617,7 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(ncnumgrp(nc)>0 )then ! default cross validation on if(mod(ndata+1,ncnumgrp(nc))== ncgroup(nc)-1)usage=ncmiter(nc) end if + if(icuse(nc) <= 0 .or. qm >= 8) rusage(iout) = .false. ! Extract pressure level and quality marks dlnpob=log(plevs(k)) ! ln(pressure in cb) @@ -670,7 +678,6 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& deallocate(presl_thin) call del3grids endif - ! Normal exit enddo loop_convinfo! loops over convinfo entry matches @@ -679,35 +686,56 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& close(lunin) deallocate(lmsg,tab,nrep) -! Write header record and data to output file for further processing - allocate(iloc(ndata)) - icount=0 - do i=1,maxobs - if(isort(i) > 0)then - icount=icount+1 - iloc(icount)=isort(i) - end if - end do - if(ndata /= icount)then - write(6,*) ' WCPBUFR: mix up in read_wcpbufr ,ndata,icount ',ndata,icount - call stop2(50) - end if - allocate(cdata_out(nreal,ndata)) - do i=1,ndata - itx=iloc(i) - do k=1,nreal - cdata_out(k,i)=cdata_all(k,itx) + nxdata=ndata + nodata=0 + if(nxdata > 0)then +! numthin=0 +! numqc=0 +! numrem=0 +! do i=1,nxdata +! if(.not. rusage(i))then +! numqc=numqc+1 +! else if(rthin(i))then +! numthin=numthin+1 +! else +! numrem=numrem+1 +! end if +! end do +! write(6,*) ' wcp ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin +! If thinned data set usage + do i=1,nxdata + if(rthin(i))cdata_all(11,i)=100._r_kind end do - end do - deallocate(iloc,isort,cdata_all) +! If flag to not save thinned data is set - compress data + do i=1,nxdata +! pmot=0 - all obs - thin obs +! pmot=1 - all obs +! pmot=2 - use obs +! pmot=3 - use obs + thin obs + if((pmot == 0 .and. .not. rthin(i)) .or. & + (pmot == 1) .or. & + (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. & + (pmot == 3 .and. rusage(i))) then + + ndata=ndata+1 + do k=1,nreal + cdata_all(k,ndata)=cdata_all(k,i) + end do + end if + end do + nodata=nodata+ndata + end if + + deallocate(rusage,rthin) + +! Write header record and data to output file for further processing - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata - write(lunout) cdata_out + write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata) - deallocate(cdata_out) + deallocate(cdata_all) -900 continue if(diagnostic_reg .and. ntest>0) write(6,*)'READ_WCPBUFR: ',& 'ntest,disterrmax=',ntest,disterrmax if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_WCPBUFR: ',& diff --git a/src/gsi/setupbend.f90 b/src/gsi/setupbend.f90 index e82aa3dec9..607311f340 100644 --- a/src/gsi/setupbend.f90 +++ b/src/gsi/setupbend.f90 @@ -715,7 +715,7 @@ subroutine setupbend(obsLL,odiagLL, & call setq(q_w(:,k),ref_rad(k-1:k+1),3) enddo - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter ! Get refractivity index-radius and [d(ln(n))/dx] in new grid. intloop: do j=1,grids_dim diff --git a/src/gsi/setupcldch.f90 b/src/gsi/setupcldch.f90 index cd3790016d..0cfda9a279 100644 --- a/src/gsi/setupcldch.f90 +++ b/src/gsi/setupcldch.f90 @@ -196,7 +196,7 @@ subroutine setupcldch(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_dia isprvd=18 ! index of subprovider do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for missing data !need obs value and error diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 90b7d183b6..4f25256c98 100644 --- a/src/gsi/setupdbz.f90 +++ b/src/gsi/setupdbz.f90 @@ -364,7 +364,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d iptrb=26 ! index of dbz perturbation do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 if ( .not. luse(i) ) then icnt_nouse = icnt_nouse + 1 diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 index dbb2f56111..682c056adf 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -42,7 +42,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim,nc_diag_read_close use m_obsLList, only: obsLList use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: oneobtest,maginnov,magoberr + use oneobmod, only: magoberr use guess_grids, only: hrdifsig,nfldsig,ges_prsi use guess_grids, only: ges_lnprsl, geop_hgtl use gridmod, only: lat2, lon2 @@ -229,7 +229,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa icat =25 ! index of data level category iptrb=26 ! index of fed perturbation do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do if (dofedoneob) then diff --git a/src/gsi/setupgust.f90 b/src/gsi/setupgust.f90 index 65f4c3caba..c6b4aa260f 100644 --- a/src/gsi/setupgust.f90 +++ b/src/gsi/setupgust.f90 @@ -224,7 +224,7 @@ subroutine setupgust(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag goverrd=grav/rd do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for missing data diff --git a/src/gsi/setuphowv.f90 b/src/gsi/setuphowv.f90 index c2b1dfe3e9..3ecb05c8ff 100644 --- a/src/gsi/setuphowv.f90 +++ b/src/gsi/setuphowv.f90 @@ -195,7 +195,7 @@ subroutine setuphowv(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do hr_offset=min_offset/60.0_r_kind diff --git a/src/gsi/setuplcbas.f90 b/src/gsi/setuplcbas.f90 index 962abbecaa..508236ec26 100644 --- a/src/gsi/setuplcbas.f90 +++ b/src/gsi/setuplcbas.f90 @@ -191,7 +191,7 @@ subroutine setuplcbas(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_dia scale=one do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for missing data diff --git a/src/gsi/setuplight.f90 b/src/gsi/setuplight.f90 index b1118dd1f8..505008b4e9 100644 --- a/src/gsi/setuplight.f90 +++ b/src/gsi/setuplight.f90 @@ -421,7 +421,7 @@ subroutine setuplight(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,light_di nobs_loc=zero do i=1,nobs - muse(i)=nint(data(11,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 enddo dup=one diff --git a/src/gsi/setuplwcp.f90 b/src/gsi/setuplwcp.f90 index 7b1549aab4..d020cbbc90 100644 --- a/src/gsi/setuplwcp.f90 +++ b/src/gsi/setuplwcp.f90 @@ -274,7 +274,7 @@ subroutine setuplwcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag iobshgt=16 ! index of observation height (m) do i=1,nobs - muse(i)=nint(data(11,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do dup=one diff --git a/src/gsi/setupmitm.f90 b/src/gsi/setupmitm.f90 index 89b01acbec..cc5b16fde3 100644 --- a/src/gsi/setupmitm.f90 +++ b/src/gsi/setupmitm.f90 @@ -195,7 +195,7 @@ subroutine setupmitm(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for duplicate observations at same location diff --git a/src/gsi/setupmxtm.f90 b/src/gsi/setupmxtm.f90 index 0c71415f80..5f332c4de5 100644 --- a/src/gsi/setupmxtm.f90 +++ b/src/gsi/setupmxtm.f90 @@ -195,7 +195,7 @@ subroutine setupmxtm(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for duplicate observations at same location diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index b16a33b414..c4cc36601d 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -217,7 +217,6 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& real(r_kind),dimension(nsig,nloz_omi+1):: doz_dz1 integer(i_kind) :: oz_ind, nind, nnz type(sparr2) :: dhx_dx - real(r_single), dimension(nsdim) :: dhx_dx_array integer(i_kind) i,nlev,ii,jj,iextra,ibin, kk, nperobs integer(i_kind) k1,k2,k,j,nz,jc,idia,irdim1,istatus,ioff0,ioff1 @@ -1170,7 +1169,6 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& real(r_kind),dimension(nsig):: prsltmp real(r_single),dimension(ireal,nobs):: diagbuf real(r_single),allocatable,dimension(:,:,:)::rdiagbuf - real(r_kind),dimension(nsig+1)::prsitmp real(r_kind),dimension(nsig)::ozgestmp integer(i_kind) i,ii,jj,iextra,ibin diff --git a/src/gsi/setuppblh.f90 b/src/gsi/setuppblh.f90 index 6d2a56b9fd..5a92494756 100644 --- a/src/gsi/setuppblh.f90 +++ b/src/gsi/setuppblh.f90 @@ -177,7 +177,7 @@ subroutine setuppblh(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag istnelv=14 ! index of station elevation (m) do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for missing data !need obs value and error diff --git a/src/gsi/setuppmsl.f90 b/src/gsi/setuppmsl.f90 index d66a6f827e..b830d26b97 100644 --- a/src/gsi/setuppmsl.f90 +++ b/src/gsi/setuppmsl.f90 @@ -191,7 +191,7 @@ subroutine setuppmsl(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do dup=one diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90 index f376f9ffde..f3c9db2bae 100644 --- a/src/gsi/setupps.f90 +++ b/src/gsi/setupps.f90 @@ -273,7 +273,7 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa ! muse = true then used do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! If HD raobs available move prepbufr version to monitor if(nhdps > 0)then diff --git a/src/gsi/setuppw.f90 b/src/gsi/setuppw.f90 index 08872c0a51..d16eecb9e6 100644 --- a/src/gsi/setuppw.f90 +++ b/src/gsi/setuppw.f90 @@ -231,7 +231,7 @@ subroutine setuppw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa iobshgt=16 ! index of observation height (m) do i=1,nobs - muse(i)=nint(data(11,i)) <= jiter + muse(i)=nint(data(11,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do dup=one diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index cebdeecd7b..ad6d727ce9 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -337,7 +337,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav iptrb=24 ! index of q perturbation do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! If HD raobs available move prepbufr version to monitor if(nhdq > 0)then diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 856715d4c2..935366650c 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -1102,10 +1102,12 @@ 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 + if (abi2km .and. regional) then + abi2km_bc = zero + abi2km_bc(2) = 233.5_r_kind + abi2km_bc(3) = 241.7_r_kind + abi2km_bc(4) = 250.5_r_kind + end if !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl diff --git a/src/gsi/setuprw.f90 b/src/gsi/setuprw.f90 index 1e3900aafa..5c31f538bd 100644 --- a/src/gsi/setuprw.f90 +++ b/src/gsi/setuprw.f90 @@ -252,7 +252,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa if(.not.proceed) return ! not all vars available, simply return ! If require guess vars available, extract from bundle ... - call init_vars_ + call init_vars_(include_w) if ( l_use_rw_columntilt) then ! @@ -287,7 +287,6 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa ! Read and reformat observations in work arrays. read(lunin)data,luse,ioid - ! index information for data array (see reading routine) ier=1 ! index of obs error ilon=2 ! index of grid relative obs location (x) @@ -566,6 +565,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa error = one/error if(dpres < zero .or. dpres > rsig)ratio_errors = zero + wgesin=zero ! Interpolate guess u, v, and w to observation location and time. call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime,& @@ -788,7 +788,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa end if end if -! Gross error checks + ! Gross error checks obserror = one/max(ratio_errors*error,tiny_r_kind) obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) residual = abs(ddiff) @@ -871,7 +871,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa jiter=jiter, muse=muse(i), nldepart=ddiff) end if endif - + ! If obs is "acceptable", load array with obs info for use ! in inner loop minimization (int* and stp* routines) if ( .not. last .and. muse(i)) then @@ -903,6 +903,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa my_head%b = cvar_b(ikx) my_head%pg = cvar_pg(ikx) + if (luse_obsdiag) then call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') my_head%diags => my_diag @@ -992,8 +993,9 @@ subroutine check_vars_ (proceed, include_w) endif end subroutine check_vars_ - subroutine init_vars_ + subroutine init_vars_(include_w) + logical,intent(in ):: include_w real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() character(len=5) :: varname diff --git a/src/gsi/setupspd.f90 b/src/gsi/setupspd.f90 index 2437ea63ce..600533ecb7 100644 --- a/src/gsi/setupspd.f90 +++ b/src/gsi/setupspd.f90 @@ -301,7 +301,7 @@ subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do dup=one diff --git a/src/gsi/setupswcp.f90 b/src/gsi/setupswcp.f90 index 6797357103..bd9c1e9690 100644 --- a/src/gsi/setupswcp.f90 +++ b/src/gsi/setupswcp.f90 @@ -268,7 +268,7 @@ subroutine setupswcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag iobshgt=16 ! index of observation height (m) do i=1,nobs - muse(i)=nint(data(11,i)) <= jiter + muse(i)=nint(data(11,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do dup=one diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index d0ec421f06..8d1c308d7f 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -412,7 +412,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav end if do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! If HD raobs available move prepbufr version to monitor if(nhdt > 0)then @@ -1109,6 +1109,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head%elat= data(ilate,i) my_head%elon= data(ilone,i) + if(npredt <= 0) write(6,*) ' npredt = ',npredt allocate(my_head%pred(npredt)) ! Set (i,j,k) indices of guess gridpoint that bound obs location diff --git a/src/gsi/setuptcamt.f90 b/src/gsi/setuptcamt.f90 index a20abb934a..77d23e5674 100644 --- a/src/gsi/setuptcamt.f90 +++ b/src/gsi/setuptcamt.f90 @@ -190,7 +190,7 @@ subroutine setuptcamt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_dia scale=one do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for missing data diff --git a/src/gsi/setuptd2m.f90 b/src/gsi/setuptd2m.f90 index 9e54171bd7..30f6a8b6e3 100644 --- a/src/gsi/setuptd2m.f90 +++ b/src/gsi/setuptd2m.f90 @@ -191,7 +191,7 @@ subroutine setuptd2m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do dup=one diff --git a/src/gsi/setupuwnd10m.f90 b/src/gsi/setupuwnd10m.f90 index 24a4e3d4f7..dcf7914020 100644 --- a/src/gsi/setupuwnd10m.f90 +++ b/src/gsi/setupuwnd10m.f90 @@ -229,7 +229,7 @@ subroutine setupuwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d goverrd=grav/rd do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for missing data diff --git a/src/gsi/setupvis.f90 b/src/gsi/setupvis.f90 index e395c4f7fb..6b514fd47b 100644 --- a/src/gsi/setupvis.f90 +++ b/src/gsi/setupvis.f90 @@ -204,7 +204,7 @@ subroutine setupvis(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags isprvd=18 ! index of subprovider do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for missing data !need obs value and error diff --git a/src/gsi/setupvwnd10m.f90 b/src/gsi/setupvwnd10m.f90 index 0f5b46900a..d3c7e573ed 100644 --- a/src/gsi/setupvwnd10m.f90 +++ b/src/gsi/setupvwnd10m.f90 @@ -229,7 +229,7 @@ subroutine setupvwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d goverrd=grav/rd do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for missing data diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 6e653a9db0..e350c7deba 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -271,7 +271,8 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav real(r_kind) err_input,err_adjst,err_final,skint,sfcr real(r_kind) dudiff_opp, dvdiff_opp, vecdiff, vecdiff_opp real(r_kind) dudiff_opp_rs, dvdiff_opp_rs, vecdiff_rs, vecdiff_opp_rs - real(r_kind) oscat_vec,ascat_vec,rapidscat_vec + real(r_kind) oscat_vec,rapidscat_vec +! real(r_kind) ascat_vec real(r_kind),dimension(nele,nobs):: data real(r_kind),dimension(nobs):: dup real(r_kind),dimension(nsig)::prsltmp,tges,zges @@ -420,7 +421,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav end if do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! If HD raobs available move prepbufr version to monitor if(nhduv > 0)then @@ -894,8 +895,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if (itype==236) then magomb=sqrt(dudiff*dudiff+dvdiff*dvdiff) ratio_errors=error/((uv_doe_a_236*magomb+uv_doe_b_236)+drpx+1.0e6_r_kind*rhgh+four*rlow) - endif - if (itype==237) then + else if (itype==237) then magomb=sqrt(dudiff*dudiff+dvdiff*dvdiff) ratio_errors=error/((uv_doe_a_237*magomb+uv_doe_b_237)+drpx+1.0e6_r_kind*rhgh+four*rlow) endif @@ -939,106 +939,98 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if (itype >=240 .and. itype <=260) then call intrp2a11(tropprs,trop5,dlat,dlon,mype) if(presw < trop5-r50) error=zero ! tropopose check for all satellite winds - endif - - if(itype >=240 .and. itype <=260) then if(i_gsdqc==2) then prsfc = r10*psges if( prsfc-presw < 100.0_r_kind) error =zero ! add check for obs within 100 hPa of sfc else if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb endif - endif - if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT - if(presw <700.0_r_kind) error=zero ! no visible winds above 700mb - endif - if(itype ==245 ) then - if( presw >399.0_r_kind .and. presw <801.0_r_kind) then !GOES IR winds - error=zero ! no data between 400-800mb - endif - endif - if(itype == 252 .and. presw >499.0_r_kind .and. presw <801.0_r_kind) then ! JMA IR winds - error=zero - endif - if(itype == 253 ) then - if(presw >401.0_r_kind .and. presw <801.0_r_kind) then ! EUMET IR winds - error=zero - endif - endif - if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top - if(presw >399.0_r_kind) error=zero - endif - if(itype ==257 .and. presw <249.0_r_kind) error=zero - if(itype ==258 .and. presw >600.0_r_kind) error=zero - if(itype ==259 .and. presw >600.0_r_kind) error=zero - if(itype ==259 .and. presw <249.0_r_kind) error=zero - endif ! qc_satwnds - -! QC GOES CAWV - some checks above as well - if (itype==247) then - prsfc = r10*psges ! surface pressure in hPa - -! Compute observed and guess wind speeds (m/s). - spdges = sqrt(ugesin* ugesin +vgesin* vgesin ) - -! Set and compute GOES CAWV specific departure parameters - LNVD_wspd = spdob - LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) - LNVD_ratio = LNVD_omb / log(LNVD_wspd) - LNVD_threshold = 3.0_r_kind - if( .not. wrf_nmm_regional) then ! LNVD check not use for CAWV winds in HWRF - if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check - (presw > prsfc-110.0_r_kind .and. isli /= 0))then ! near surface check 110 ~1km - error = zero - endif - endif -! check for direction departure gt 50 deg - wdirdiffmax=50._r_kind - call getwdir(uob,vob,wdirob) - call getwdir(ugesin,vgesin,wdirgesin) - if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & - abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then - error = zero - endif - endif + if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT + if(presw <700.0_r_kind) error=zero ! no visible winds above 700mb + else if(itype ==245 ) then + if( presw >399.0_r_kind .and. presw <801.0_r_kind) then !GOES IR winds + error=zero ! no data between 400-800mb + endif + else if(itype == 252 )then + if( presw >499.0_r_kind .and. presw <801.0_r_kind) then ! JMA IR winds + error=zero + end if + else if(itype == 253 ) then + if(presw >401.0_r_kind .and. presw <801.0_r_kind) then ! EUMET IR winds + error=zero + endif + else if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top + if(presw >399.0_r_kind) error=zero + +! QC GOES CAWV - some checks above as well + else if (itype==247) then + prsfc = r10*psges ! surface pressure in hPa + +! Compute observed and guess wind speeds (m/s). + spdges = sqrt(ugesin* ugesin +vgesin* vgesin ) + +! Set and compute GOES CAWV specific departure parameters + LNVD_wspd = spdob + LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) + LNVD_ratio = LNVD_omb / log(LNVD_wspd) + LNVD_threshold = 3.0_r_kind + if( .not. wrf_nmm_regional) then ! LNVD check not use for CAWV winds in HWRF + if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check + (presw > prsfc-110.0_r_kind .and. isli /= 0))then ! near surface check 110 ~1km + error = zero + endif + endif +! check for direction departure gt 50 deg + wdirdiffmax=50._r_kind + call getwdir(uob,vob,wdirob) + call getwdir(ugesin,vgesin,wdirgesin) + if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & + abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then + error = zero + endif ! QC MODIS winds - if (itype==257 .or. itype==258 .or. itype==259 .or. itype ==260) then -! Get guess values of tropopause pressure and sea/land/ice -! mask at observation location - prsfc = r10*prsfc ! surface pressure in hPa - -! Compute observed and guess wind speeds (m/s). - spdges = sqrt(ugesin* ugesin +vgesin* vgesin ) + else if (itype==257 .or. itype==258 .or. itype==259 .or. itype ==260) then + if(itype ==257 .and. presw <249.0_r_kind) error=zero + if(itype ==258 .and. presw >600.0_r_kind) error=zero + if(itype ==259 .and. presw >600.0_r_kind) error=zero + if(itype ==259 .and. presw <249.0_r_kind) error=zero +! Get guess values of tropopause pressure and sea/land/ice +! mask at observation location + prsfc = r10*prsfc ! surface pressure in hPa + +! Compute observed and guess wind speeds (m/s). + spdges = sqrt(ugesin* ugesin +vgesin* vgesin ) -! Set and computes modis specific qc parameters - LNVD_wspd = spdob - LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) - LNVD_ratio = LNVD_omb / log(LNVD_wspd) - LNVD_threshold = 3.0_r_kind - if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check - (presw > prsfc-r200 .and. isli /= 0))then ! near surface check - error = zero - endif - endif ! ??? - -! QC AVHRR winds - if (itype==244) then -! Get guess values of tropopause pressure and sea/land/ice -! mask at observation location - prsfc = r10*prsfc ! surface pressure in hPa - -! Set and computes modis specific qc parameters - LNVD_wspd = spdob - LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) - LNVD_ratio = LNVD_omb / log(LNVD_wspd) - LNVD_threshold = 3.0_r_kind - - if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check - (presw > prsfc-r200 .and. isli /= 0))then ! near surface check - error = zero +! Set and computes modis specific qc parameters + LNVD_wspd = spdob + LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) + LNVD_ratio = LNVD_omb / log(LNVD_wspd) + LNVD_threshold = 3.0_r_kind + if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check + (presw > prsfc-r200 .and. isli /= 0))then ! near surface check + error = zero + endif + +! QC AVHRR winds + else if (itype==244) then +! Get guess values of tropopause pressure and sea/land/ice +! mask at observation location + prsfc = r10*prsfc ! surface pressure in hPa + +! Set and computes modis specific qc parameters + LNVD_wspd = spdob + LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) + LNVD_ratio = LNVD_omb / log(LNVD_wspd) + LNVD_threshold = 3.0_r_kind + + if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check + (presw > prsfc-r200 .and. isli /= 0))then ! near surface check + error = zero + endif + endif ! end if all satellite winds endif - endif ! end if all satellite winds + endif ! QC WindSAT winds @@ -1050,10 +1042,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav abs(dvdiff) > qcv ) then ! v component check error = zero endif - endif ! QC ASCAT winds - if (itype==290) then + else if (itype==290) then qcu = five qcv = five ! Compute innovations for opposite vectors @@ -1061,7 +1052,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav dvdiff_opp = -vob - vgesin vecdiff = sqrt(dudiff**2 + dvdiff**2) vecdiff_opp = sqrt(dudiff_opp**2 + dvdiff_opp**2) - ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) +! ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) if ( abs(dudiff) > qcu .or. & ! u component check abs(dvdiff) > qcv .or. & ! v component check @@ -1069,10 +1060,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav error = zero endif - endif ! QC RAPIDSCAT winds - if (itype==296) then + else if (itype==296) then qcu = five qcv = five ! Compute innovations for opposite vectors @@ -1086,10 +1076,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav vecdiff_rs > vecdiff_opp_rs ) then ! ambiguity check error = zero endif - endif ! QC OSCAT winds - if (itype==291) then + else if (itype==291) then qcu = r6 qcv = r6 oscat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) @@ -1267,7 +1256,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav nn=1 if (.not. muse(i)) then nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 + if(error*ratio_errors >= tiny_r_kind)nn=3 +! if((data(iqc,i) >= 8 .and. data(iqc,i) <= 10) .or. & +! error*ratio_errors >= tiny_r_kind)nn=3 end if do k = 1,npres_print if(presw >ptop(k) .and. presw<=pbot(k))then @@ -1325,10 +1316,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head%ib=ibeta(ikx) my_head%ik=ikapa(ikx) my_head%luse=luse(i) -! if( i==3) print *,'SETUPW',my_head%ures,my_head%vres,my_head%err2 - if (luse_obsdiag) then - endif ! (luse_obsdiag) +! if( i==3) print *,'SETUPW',my_head%ures,my_head%vres,my_head%err2 + if(oberror_tune) then my_head%upertb=data(iptrbu,i)/error/ratio_errors @@ -1353,6 +1343,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav endif endif + if (luse_obsdiag) then call obsdiagNode_assert(my_diagu, my_head%idv,my_head%iob,my_head%ich0+1_i_kind,myname,"my_diagu:my_head") call obsdiagNode_assert(my_diagv, my_head%idv,my_head%iob,my_head%ich0+2_i_kind,myname,"my_diagv:my_head") diff --git a/src/gsi/setupwspd10m.f90 b/src/gsi/setupwspd10m.f90 index c702faaecf..6beaae340c 100644 --- a/src/gsi/setupwspd10m.f90 +++ b/src/gsi/setupwspd10m.f90 @@ -243,7 +243,7 @@ subroutine setupwspd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d goverrd=grav/rd do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter + muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8 end do ! Check for duplicate observations at same location diff --git a/src/gsi/state_vectors.f90 b/src/gsi/state_vectors.f90 index df332303b0..5a573785e7 100644 --- a/src/gsi/state_vectors.f90 +++ b/src/gsi/state_vectors.f90 @@ -400,7 +400,7 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) ! Independent part of vector ! Sum,Max,Min and number of points -!$omp parallel do schedule(dynamic,1) !private(i) +!$omp parallel do schedule(static,1) private(i) do i = 1,ns3d if(xst%r3(i)%mykind==r_single)then zloc(i)= sum_mask(xst%r3(i)%qr4,ihalo=1) @@ -413,7 +413,7 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) endif nloc(i) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields enddo -!$omp parallel do schedule(dynamic,1) !private(i) +!$omp parallel do schedule(static,1) private(i) do i = 1,ns2d if(xst%r2(i)%mykind==r_single)then zloc(ns3d+i)= sum_mask(xst%r2(i)%qr4,ihalo=1) @@ -433,7 +433,7 @@ 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) -!$omp parallel do schedule(dynamic,1) !private(i) +!$omp parallel do schedule(static,1) private(i) do i=1,nvars psum(i)=SUM(zall(i,:)) pnum(i)=SUM(nall(i,:)) diff --git a/src/gsi/statsconv.f90 b/src/gsi/statsconv.f90 index 3011fdefea..fc105515ff 100644 --- a/src/gsi/statsconv.f90 +++ b/src/gsi/statsconv.f90 @@ -1591,7 +1591,7 @@ subroutine statsconv(mype,& ' number with abs(guess topography-station elevation) > 200m = ',i8) 920 format(a44,i7) 924 format(a50) -925 format(' number of ',a5,' obs that failed gross test = ',I5,' nonlin qc test = ',I5) +925 format(' number of ',a7,' obs that failed gross test = ',I6,' nonlin qc test = ',I6) 949 format(' number of ',a5,' obs = ',i7,' pen= ',e25.18,' cpen= ',g13.6) 950 format(' type ',a7,' jiter ',i3,' nread ',i9,' nkeep ',i7,' num ',i7) 951 format(' type ',a7,' pen= ',e25.18,' qcpen= ',e25.18,' r= ',g13.6,' qcr= ',g13.6) diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index 849d2ff5c9..c66bb58291 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -461,6 +461,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! penalties for moisture constraint if(.not. ltlint)then +!$omp parallel sections +!$omp section if(.not.ljc4tlevs) then call stplimq(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,4),pbc(1,5),nstep,ntguessig) if(pjcalc)then @@ -485,7 +487,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end do end if -!$omp parallel sections !$omp section ! penalties for gust constraint if(gustpresent) then @@ -534,142 +535,140 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & 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 -!$omp parallel sections private (ibin,it,j) +! if (ljclimqc) then !$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) - else - do ibin=1,nobs_bins - if (nobs_bins /= nfldsig) then - it=ntguessig - else - it=ibin - end if - call stplimqc(dval(ibin),sval(ibin),sges,pbcql(1,ibin),nstep,it,'ql') - end do - do ibin=1,nobs_bins - do j=1,nstep - pbc(j,13) = pbc(j,13)+pbcql(j,ibin) - end do - end do - if(pjcalc)then - do ibin=1,nobs_bins - pj(13,ibin)=pj(13,ibin)+pbcql(1,ibin)+pbcql(ipenloc,ibin) - end do - end if - end if + if (qlpresent .and. ljclimqc ) 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) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcql(1,ibin),nstep,it,'ql') + end do + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,13) = pbc(j,13)+pbcql(j,ibin) + end do + end do + if(pjcalc)then + do ibin=1,nobs_bins + pj(13,ibin)=pj(13,ibin)+pbcql(1,ibin)+pbcql(ipenloc,ibin) + end do + end if end if + end if !$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) - else - do ibin=1,nobs_bins - if (nobs_bins /= nfldsig) then - it=ntguessig - else - it=ibin - end if - call stplimqc(dval(ibin),sval(ibin),sges,pbcqi(1,ibin),nstep,it,'qi') - end do - do ibin=1,nobs_bins - do j=1,nstep - pbc(j,14) = pbc(j,14)+pbcqi(j,ibin) - end do - end do - if(pjcalc)then - do ibin=1,nobs_bins - pj(14,ibin)=pj(14,ibin)+pbcqi(1,ibin)+pbcqi(ipenloc,ibin) - end do - end if - end if + if (qipresent .and. ljclimqc ) 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) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcqi(1,ibin),nstep,it,'qi') + end do + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,14) = pbc(j,14)+pbcqi(j,ibin) + end do + end do + if(pjcalc)then + do ibin=1,nobs_bins + pj(14,ibin)=pj(14,ibin)+pbcqi(1,ibin)+pbcqi(ipenloc,ibin) + end do + end if end if + end if !$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) - else - do ibin=1,nobs_bins - if (nobs_bins /= nfldsig) then - it=ntguessig - else - it=ibin - end if - call stplimqc(dval(ibin),sval(ibin),sges,pbcqr(1,ibin),nstep,it,'qr') - end do - do ibin=1,nobs_bins - do j=1,nstep - pbc(j,15) = pbc(j,15)+pbcqr(j,ibin) - end do - end do - if(pjcalc)then - do ibin=1,nobs_bins - pj(15,ibin)=pj(15,ibin)+pbcqr(1,ibin)+pbcqr(ipenloc,ibin) - end do - end if - end if + if (qrpresent .and. ljclimqc ) 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) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcqr(1,ibin),nstep,it,'qr') + end do + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,15) = pbc(j,15)+pbcqr(j,ibin) + end do + end do + if(pjcalc)then + do ibin=1,nobs_bins + pj(15,ibin)=pj(15,ibin)+pbcqr(1,ibin)+pbcqr(ipenloc,ibin) + end do + end if end if + end if !$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) - else - do ibin=1,nobs_bins - if (nobs_bins /= nfldsig) then - it=ntguessig - else - it=ibin - end if - call stplimqc(dval(ibin),sval(ibin),sges,pbcqs(1,ibin),nstep,it,'qs') - end do - do ibin=1,nobs_bins - do j=1,nstep - pbc(j,16) = pbc(j,16)+pbcqs(j,ibin) - end do - end do - if(pjcalc)then - do ibin=1,nobs_bins - pj(16,ibin)=pj(16,ibin)+pbcqs(1,ibin)+pbcqs(ipenloc,ibin) - end do - end if - end if + if (qspresent .and. ljclimqc ) 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) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcqs(1,ibin),nstep,it,'qs') + end do + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,16) = pbc(j,16)+pbcqs(j,ibin) + end do + end do + if(pjcalc)then + do ibin=1,nobs_bins + pj(16,ibin)=pj(16,ibin)+pbcqs(1,ibin)+pbcqs(ipenloc,ibin) + end do + end if end if + end if !$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) - else - do ibin=1,nobs_bins - if (nobs_bins /= nfldsig) then - it=ntguessig - else - it=ibin - end if - call stplimqc(dval(ibin),sval(ibin),sges,pbcqg(1,ibin),nstep,it,'qg') - end do - do ibin=1,nobs_bins - do j=1,nstep - pbc(j,17) = pbc(j,17)+pbcqg(j,ibin) - end do - end do - if(pjcalc)then - do ibin=1,nobs_bins - pj(17,ibin)=pj(17,ibin)+pbcqg(1,ibin)+pbcqg(ipenloc,ibin) - end do - end if - end if + if (qgpresent .and. ljclimqc ) 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) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcqg(1,ibin),nstep,it,'qg') + end do + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,17) = pbc(j,17)+pbcqg(j,ibin) + end do + end do + if(pjcalc)then + do ibin=1,nobs_bins + pj(17,ibin)=pj(17,ibin)+pbcqg(1,ibin)+pbcqg(ipenloc,ibin) + end do + end if end if + end if !$omp end parallel sections - end if ! ljclimqc +! end if ! ljclimqc end if @@ -680,13 +679,13 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & pbcjo=zero_quad do ibin=1,nobs_bins ! == obs_bins do j=1,nobs_type - do i=1,4 + do i=1,nstep pbcjo(i,j)=pbcjo(i,j)+pbcjoi(i,j,ibin) end do end do enddo do j=1,nobs_type - do i=1,4 + do i=1,nstep pbc(i,n0+j)=pbcjo(i,j) end do end do @@ -864,21 +863,37 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if final_ii=ii end do stepsize + if(kprt >= 2 .and. iter == 0)then call mpl_allreduce(ipen,nobs_bins,pj) if(mype == minmype)call prnt_j(pj,n0,ipen,kprt) end if stpinout=stp(istp_use) -! Estimate terms in penalty - if(mype == minmype)then - if(print_verbose)then + +! Check for final stepsize negative (probable error) + if(stpinout <= zero)then + if(mype == minmype)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,130) final_ii,bx,cx,stp(final_ii) + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) end if + end_iter = .true. + end if +199 format(' stepsize stprat = ',6(e25.18,1x)) +200 format(' stepsize estimates = ',6(e25.18,1x)) +201 format(' stepsize guesses = ',(10(e13.6,1x))) +202 format(' penalties = ',(10(e13.6,1x))) + +! If convergence or failure of stepsize calculation return + +! Estimate terms in penalty + if(mype == minmype)then pjcostnew(1) = pbc(1,1) ! Jb pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc pjcostnew(4)=zero @@ -898,45 +913,27 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & 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 == minmype)then - write(iout_iter,130) final_ii,bx,cx,stp(final_ii) - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) - end if - end_iter = .true. - end if -199 format(' stepsize stprat = ',6(e25.18,1x)) -200 format(' stepsize estimates = ',6(e25.18,1x)) -201 format(' stepsize guesses = ',(10(e13.6,1x))) -202 format(' penalties = ',(10(e13.6,1x))) - -! If convergence or failure of stepsize calculation return - if (end_iter) then - call timer_fnl('stpcalc') - return - endif + if (.not. end_iter) then ! Update solution !$omp parallel do schedule(dynamic,1) private(i,ii) - 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 + 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 + endif ! Finalize timer diff --git a/src/gsi/stpfed.f90 b/src/gsi/stpfed.f90 index 2a69dd08ec..6511a27968 100644 --- a/src/gsi/stpfed.f90 +++ b/src/gsi/stpfed.f90 @@ -55,14 +55,12 @@ subroutine stpfed(fedhead,rval,sval,out,sges,nstep) use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600 use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer - use gridmod, only: wrf_mass_regional, fv3_regional use wrf_vars_mod, only : fed_exist use m_obsNode, only: obsNode use m_fedNode , only: fedNode use m_fedNode , only: fedNode_typecast use m_fedNode , only: fedNode_nextcast ! use directDA_radaruse_mod, only: l_use_fed_directDA - use radarz_cst, only: mphyopt implicit none diff --git a/src/gsi/stprw.f90 b/src/gsi/stprw.f90 index c5f996463c..a61a53f54b 100644 --- a/src/gsi/stprw.f90 +++ b/src/gsi/stprw.f90 @@ -124,19 +124,13 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) ier=0 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 (if_use_w_vr.and.istatus==0) then - include_w=.true. - else - include_w=.false. - end if 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) + include_w=.false. + call gsi_bundlegetpointer(sval,'w',sw,istatus) if (if_use_w_vr.and.istatus==0) then - include_w=.true. - else - include_w=.false. + call gsi_bundlegetpointer(rval,'w',rw,istatus) + if(istatus == 0)include_w=.true. end if if(ier/=0)return diff --git a/src/gsi/turbl.f90 b/src/gsi/turbl.f90 index 9397397863..f4e0cdbd4d 100644 --- a/src/gsi/turbl.f90 +++ b/src/gsi/turbl.f90 @@ -41,7 +41,6 @@ subroutine turbl(uges,vges,pges,tges,oges,zges,termu,termv,termt,jstart,jstop) use kinds,only: r_kind,i_kind use constants,only: zero,one,two,half,rd_over_g,rd_over_cp,grav use gridmod,only: lat2,lon2,nsig,nsig_hlf - use turblmod, only: use_pbl use turblmod, only: dudz,dvdz,dodz,ri,rf,zi,km,kh,sm,sh use turblmod, only: lmix,dudtm,dvdtm,dtdtm,rdzi,rdzl use turblmod, only: kar0my20 @@ -70,8 +69,6 @@ subroutine turbl(uges,vges,pges,tges,oges,zges,termu,termv,termt,jstart,jstop) real(r_kind) px,rdzik,rdzlk,kmrdz,khrdz,ssq,aux,l0 integer(i_kind) i,j,k - if(.not. use_pbl)return - do k=1,nsig_hlf do j=jstart,jstop do i=1,lat2 diff --git a/src/gsi/turbl_ad.f90 b/src/gsi/turbl_ad.f90 index 66b0fdda60..9f4d7ef1b5 100644 --- a/src/gsi/turbl_ad.f90 +++ b/src/gsi/turbl_ad.f90 @@ -40,7 +40,6 @@ subroutine turbl_ad(pges,tges,oges,u,v,prs,t,termu,termv,termt,jstart,jstop) use constants, only: rd_over_cp,two,rd_over_g,half,zero,one,three,grav use kinds, only: r_kind,i_kind use gridmod, only: lat2,lon2,nsig,nsig_hlf - use turblmod, only: use_pbl use turblmod, only: dudz,dvdz,dodz,ri,rf,kar0my20,zi,km,kh,sm,sh use turblmod, only: lmix,dudtm,dvdtm,dtdtm,rdzi,rdzl use turblmod, only: a0my20,c0my20,d0my20, & @@ -76,8 +75,6 @@ subroutine turbl_ad(pges,tges,oges,u,v,prs,t,termu,termv,termt,jstart,jstop) real(r_kind):: kmaz_bck,khaz_bck,kmaz_tl,khaz_tl integer(i_kind) i,j,k - if(.not. use_pbl)return - do i=1,lat2 do j=jstart,jstop diff --git a/src/gsi/turbl_tl.f90 b/src/gsi/turbl_tl.f90 index 8a625c29f3..7b2a5c0c7c 100644 --- a/src/gsi/turbl_tl.f90 +++ b/src/gsi/turbl_tl.f90 @@ -37,7 +37,6 @@ subroutine turbl_tl(pges,tges,oges,u,v,prs,t,termu,termv,termt,jstart,jstop) use constants,only: rd_over_cp,two,rd_over_g,half,zero,one,three,grav use kinds,only: r_kind,i_kind use gridmod, only: lat2,lon2,nsig,nsig_hlf - use turblmod, only: use_pbl use turblmod, only: dudz,dvdz,dodz,ri,rf,kar0my20,zi,km,kh,sm,sh use turblmod, only: lmix,dudtm,dvdtm,dtdtm,rdzi,rdzl use turblmod, only: a0my20,c0my20,d0my20,f7my20,f8my20,karmy20 @@ -70,7 +69,6 @@ subroutine turbl_tl(pges,tges,oges,u,v,prs,t,termu,termv,termt,jstart,jstop) integer(i_kind) i,j,k integer(i_kind),dimension(nsig):: lssq - if(.not. use_pbl)return do j=jstart,jstop do i=1,lat2 diff --git a/src/gsi/windht.f90 b/src/gsi/windht.f90 index 09207d38b8..bd685155c4 100644 --- a/src/gsi/windht.f90 +++ b/src/gsi/windht.f90 @@ -139,7 +139,7 @@ subroutine destroy_windht_lists end subroutine destroy_windht_lists - subroutine find_wind_height(cprov,csubprov,finalheight) + subroutine find_wind_height(cprov,csubprov,finalheight,kcount) !abstract: Find provider and subprovider in pre-determined arrays !Then return wind sensor height @@ -149,6 +149,7 @@ subroutine find_wind_height(cprov,csubprov,finalheight) character(len=8),intent(in)::cprov,csubprov real(r_kind),intent(out)::finalheight + integer,dimension(3),intent(inout)::kcount !local vars integer(i_kind)::i @@ -156,16 +157,35 @@ subroutine find_wind_height(cprov,csubprov,finalheight) !sanity check if (.not.fexist) then - print*, "WARNING: File containing sensor heights does not exist. Defaulting to 10 m..." + + if(kcount(1) < 10)then + print*, "WARNING: File containing sensor heights does not exist. Defaulting to 10 m..." + else if(kcount(1) == 10)then + print*, "WARNING: List of providers not properly in memory. Defaulting to 10 m..." + print*, "Many values see kcount (1) below " + end if + kcount(1) = kcount(1) + 1 finalheight=r10 return elseif(.not.listexist) then - print*, "WARNING: List of providers not properly in memory. Defaulting to 10 m..." + if(kcount(2) < 10)then + print*, "WARNING: List of providers not properly in memory. Defaulting to 10 m..." + else if(kcount(2) == 10)then + print*, "WARNING: List of providers not properly in memory. Defaulting to 10 m..." + print*, "Many values see kcount (2) below " + end if + kcount(2) = kcount(2) + 1 finalheight=r10 return elseif (numprovs>nmax) then - print*, "WARNING: Invalid number of provider/subprovider combinations (number,max)=",numprovs,nmax - print*, "WARNING: Defaulting to 10 m wind sensor height!" + if(kcount(3) < 10)then + print*, "WARNING: Invalid number of provider/subprovider combinations (number,max)=",numprovs,nmax + print*, "WARNING: Defaulting to 10 m wind sensor height!" + else if(kcount(3) == 10)then + print*, "WARNING: Invalid number of provider/subprovider combinations (number,max)=",numprovs,nmax + print*, "Many values see kcount (3) below " + end if + kcount(3) = kcount(3) + 1 finalheight=r10 return endif diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90 index 27a83d6e48..02160c9ccd 100644 --- a/src/gsi/write_incr.f90 +++ b/src/gsi/write_incr.f90 @@ -95,6 +95,7 @@ subroutine write_fv3_inc_ (grd,filename,mype_out,gfs_bundle,ibin) use state_vectors, only: svars3d use mpeu_util, only: getindex use control2state_mod, only: control2state + use ensctl2state_mod, only: ensctl2state implicit none